Received: from vm.uni-c.dk by nbivax.nbi.dk; Sun, 3 Dec 89 00:08 +0100 (NBI,
 Copenhagen)
Received: from AECLCR by vm.uni-c.dk (Mailer R2.03B) with BSMTP id 0820; Sun,
 03 Dec 89 00:10:04 DNT
Date: Fri, 01 Dec 1989 11:38 EST
From: David Radford <02046@AECLCR.bitnet>
Subject: Update files....
To: JN@nbital.nbi.dk

============================ file CFPRINT.UPD ==========================
-   41,   41
5002  CALL ASK2(45HType P/D/S to Print/Delete/Save output file ?,
     +          45,ANS,NC,1)
      IF (NC.EQ.0.OR.ANS(1:1).EQ.'P'.OR.ANS(1:1).EQ.'p') THEN
         CLOSE(UNIT=3,STATUS='PRINT/DELETE')
      ELSEIF (ANS(1:1).EQ.'D'.OR.ANS(1:1).EQ.'d') THEN
         CLOSE(UNIT=3,STATUS='DELETE')
      ELSEIF (ANS(1:1).EQ.'S'.OR.ANS(1:1).EQ.'s') THEN
         CLOSE(UNIT=3)
      ELSE
         GO TO 5002
      ENDIF
/
=========================== end of CFPRINT.UPD =========================
============================ file CFTRANS.UPD ==========================
-   11,   11
      DATA IR,IW/5,6/
-   61,   63
      INTEGER*2 NGAM(600,600)
      INTEGER*2 IX0(600,600)
      INTEGER*2 IY0(600,600)
-   69
      DO 110 J=1,600
         DO 100 I=1,600
            NGAM(I,J)=0
            IX0(I,J)=0
            IY0(I,J)=0
100      CONTINUE
110   CONTINUE
 
/
=========================== end of CFTRANS.UPD =========================
============================ file EFFIT.UPD ==========================
-   23,   23
      INTEGER*2 ICMNDS(20),ICMND,PROMPT
-   27,   27
     +            'DF','WP','HE','MD','AD','DE','CR','EX','HC','ST'/
-   61,   61
      DO 50 K=1,20
-   68,   73
     *       1100,1200,1300,1400,1500,1600,1700,1800,1900,5000 ),K
C              FT   LP   FX   FR   ND   DD   X0   NX   Y0   NY
C              DF   WP   HE   MD   AD   DE   CR   EX   HC   ST
80    CALL ININ(ANS(3:40),NC-2,IDATA,IN,IN2,&999)
      GO TO ( 100, 200, 300, 300, 500, 600, 700, 800, 900,1000,
     *       1100,1200,1300,1400,1500,1600,1700,1800,1900,5000 ),K
-  223
1900  CALL HCOPY(JG)
      GO TO 30
 
-  532
C nbi version ....................................................
     +' HC'9X,'generate hardcopy of graphics screen (Grinnell',
     +  ' screens only)'/
C nbi version end ................................................
/
=========================== end of EFFIT.UPD =========================
============================ file GELIFT.UPD ==========================
- 1547
 
- 2487, 2487
- 2952
 
- 3259, 3260
         ENDIF
         RESETP=.TRUE.
- 3265, 3266
         ENDIF
         RESETW=.TRUE.
- 3760, 3760
          CALL ASK(36HEnter F,G,H (rtn for default values),36,ANS,NC)
/
=========================== end of GELIFT.UPD =========================
============================ file LF8R_NEW.UPD ==========================
-   11,   11
      REAL*4 EGY(600),THRESH1,THRESH2,MEDIFF,MEDIF1
-   51
      COMMAND(1:2)='DU'
      CALL DUMP
-  135,  135
2600  IF (COMMAND(2:2).EQ.'L') THEN
         CALL WRLISTS
      ELSE
         CALL WRSTO
      ENDIF
-  147,  149
5002     CALL ASK2(45HType P/D/S to Print/Delete/Save output file ?,
     +             45,COMMAND,NC,1)
         IF (NC.EQ.0.OR.COMMAND(1:1).EQ.'P'.OR.COMMAND(1:1).EQ.'p') THEN
            CLOSE(UNIT=3,STATUS='PRINT/DELETE')
         ELSEIF (COMMAND(1:1).EQ.'D'.OR.COMMAND(1:1).EQ.'d') THEN
            CLOSE(UNIT=3,STATUS='DELETE')
         ELSEIF (COMMAND(1:1).EQ.'S'.OR.COMMAND(1:1).EQ.'s') THEN
            CLOSE(UNIT=3)
         ELSE
            GO TO 5002
         ENDIF
-  180,  185
         E2  = 0.0
         DE2 = 0.0
         R2  = 0.0
         I12 = 0
      ELSE
         E2  = ENGX(I2,30)
         DE2 = DENGX(I2,30)
         R2  = RESULT(I2,30)
-  192,  199
      DIFF  = ENGX(I1,30)+E2-(ENGX(I3,30)+ENGX(I4,30))
      DDIFF = SQRT( DENGX(I1,30)**2 + DE2**2
     +            + DENGX(I3,30)**2 + DENGX(I4,30)**2)
      WRITE (3,20,ERR=10)
     +      ENGX(I1,30),NINT(DENGX(I1,30)*100.0),
     +      E2,NINT(DE2*100.0),
     +      ENGX(I3,30),NINT(DENGX(I3,30)*100.0),
     +      ENGX(I4,30),NINT(DENGX(I4,30)*100.0),
     +      DIFF,NINT(DDIFF*100.0),
     +      RESULT(I1,30),R2,FLOAT(I12)/100.0,
     +      RESULT(I3,30),RESULT(I4,30),FLOAT(INT(I4))/100.0
10    WRITE (6,30,ERR=100)
     +      ENGX(I1,30),NINT(DENGX(I1,30)*100.0),
     +      E2,NINT(DE2*100.0),
     +      ENGX(I3,30),NINT(DENGX(I3,30)*100.0),
     +      ENGX(I4,30),NINT(DENGX(I4,30)*100.0),
     +      DIFF,NINT(DDIFF*100.0),
     +      FLOAT(I12)/100.0,FLOAT(INT(I4))/100.0
20    FORMAT(2(2(F8.2,'(',I2,')'),2X),F6.2,'(',I2,')',2(2X,3F7.1))
30    FORMAT(2(2(F8.2,'(',I2,')'),2X),F6.2,'(',I2,')',2X,2F7.1)
-  368,  369
120      CALL ASK(40HDump file name = ? (default .EXT = .DMP),40,
-  377,  377
         CLOSE(2,ERR=130)
130      OPEN(2,FILE=DMPNAM,FORM='UNFORMATTED',STATUS='OLD',
-  527,  528
      WRITE(6,50)
40    FORMAT(6X,'E1',10X,'E2',12X,'E3',10X,'E4',9X,'Delta-E',
     +       6X,'I1     I2    I1x2      I3     I4    I3x4')
50    FORMAT(6X,'E1',10X,'E2',12X,'E3',10X,'E4',9X,'Delta-E',
     +       5X,'I1x2   I3x4')
-  556,  557
                     SUM = ENGX(A1(K),30)+ENGX(C(J),30)
                     IF (ABS(SUM-ENGX(C(I),30)).LE.T3) THEN
-  569,  569
            SUM1 = ENGX(C(I),30)+ENGX(C1(J),30)
-  578,  578
                        SUM2 = ENGX(A1(K),30)+ENGX(A2(L),30)
-  590
      WRITE(3,40)
      WRITE(6,50)
-  596,  597
               SUM = ENGX(C(K),30)+ENGX(C(J),30)
               IF (ABS(SUM-ENGX(C(I),30)).LE.T3)
-  607,  607
               SUM1 = ENGX(C(I),30)+ENGX(C(J),30)
-  612,  612
                     SUM2 = ENGX(C(K),30)+ENGX(C(L),30)
-  623
      WRITE(3,40)
      WRITE(6,50)
-  714
     +   '  WL    : write gamma-ray lists to a disk file.'/
     +   '  RL    : read gamma-ray lists from a disk file.'/
-  731,  731
      REAL*4 EGY(600),THRESH1,THRESH2,MEDIFF,MEDIF1
- 1496, 1496
      REAL*4 EGY(600),THRESH1,THRESH2,MEDIFF,MEDIF1
- 1535, 1535
20       FORMAT(2X,15F8.2/2X,15F8.2/2X,15F8.2/)
- 1692
      DO 600 K=1,30
         DO 590 J=1,600
            RESULT(J,K)=0.0
            ERROR(J,K)=0.0
590      CONTINUE
600   CONTINUE
 
- 1990, 1990
      INTEGER*2 IY0(600,600)
- 2002, 2003
      OPEN (1,FILE=OUTNAM,FORM='UNFORMATTED',ACCESS='DIRECT',
     +        STATUS='OLD',ERR=700)
 
      DO 40 I=1,600
         DO 35 J=1,600
            IY0(J,I)=0
35       CONTINUE
40    CONTINUE
- 2250, 2252
      SUBROUTINE WRLISTS
 
C         ....write/read gamma-ray lists to/from disk file....
- 2266
      INTEGER NLIST(26),LIST(40,26)
      COMMON /LIST/ NLIST,LIST
 
      CHARACTER*26 LISTNAM
      DATA LISTNAM /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
 
      CHARACTER*40 FILNAM
      CHARACTER*1 LNAME
 
 
10    CALL ASK(40HList file name = ? (default .EXT = .LIS),40,FILNAM,K)
      IF (K.LT.1) RETURN
 
C         if necessary, add default .EXT = .LIS....
 
      CALL SETEXT(FILNAM,4H.LIS,I)
 
      IF (COMMAND(1:1).EQ.'W') THEN
         OPEN(1,FILE=FILNAM,STATUS='NEW')
         DO 100 I=1,26
            IF (NLIST(I).GT.0) THEN
               WRITE(1,50) LISTNAM(I:I)
50             FORMAT(A1)
               DO 80 J=1,NLIST(I)
                  WRITE(1,60) EGY(LIST(J,I))
60                FORMAT(F7.2)
80             CONTINUE
               WRITE(1,60) 0.0
            ENDIF
100      CONTINUE
 
      ELSE
         OPEN(1,FILE=FILNAM,STATUS='OLD',ERR=900)
 
500      READ (1,50,END=700,ERR=920) LNAME
         DO 530 I=1,26
            IF (LNAME.EQ.LISTNAM(I:I)) GO TO 550
530      CONTINUE
         GO TO 500
 
550      NL=I
         DO 600 I=1,40
560         READ (1,*,END=700,ERR=920) EG
            IF (EG.EQ.0.0) GO TO 500
            DO 580 IG=1,NGAM
               IF (ABS(EGY(IG)-EG).LT.MEDIFF) THEN
                  IF (IG.LT.NGAM) THEN
                     IF (ABS(EGY(IG)-EG).GT.ABS(EGY(IG+1)-EG)) GO TO 580
                  ENDIF
                  LIST(I,NL) = IG
                  NLIST(NL) = I
                  GO TO 600
               ENDIF
580         CONTINUE
            WRITE(6,590) LNAME,EG
590         FORMAT('  Bad energy for list ',A1,':',F8.2)
            GO TO 560
600      CONTINUE
 
700      CALL LISTCHAR
 
      ENDIF
 
      CLOSE(1)
      RETURN
 
900   WRITE(6,910)
910   FORMAT('  File does not exist.')
      GO TO 10
920   WRITE(6,930)
930   FORMAT('  Cannot read file. WARNING: Lists may contain errors.')
      CALL LISTCHAR
      CLOSE(1)
      GO TO 10
 
      END
 
C=======================================================================
 
      SUBROUTINE WRSTO
 
C         ....write/read result # 30 to/from disk file LF8R.STO....
 
      REAL*4 EGY(600),THRESH1,THRESH2,MEDIFF
      REAL*4 RESULT(600,30),ERROR(600,30)
      REAL*4 ENGY(600,30),DENGY(600,30),ENGX(600,30),DENGX(600,30)
      INTEGER*4 NRESULT(30),NCHAR(30),NGAM
      INTEGER*2 INT(600),EINT(600)
      INTEGER*2 FEGY(600),DFEGY(600),FEGX(600),DFEGX(600)
      CHARACTER*1 SELFCO(600)
      CHARACTER*240 TITLE(30)
      CHARACTER*40 COMMAND,STONAM
      COMMON /C1/ EGY,THRESH1,THRESH2,MEDIFF,RESULT,ERROR,
     +            ENGY,DENGY,ENGX,DENGX,NRESULT,NCHAR,NGAM,INT,EINT,
     +            FEGY,DFEGY,FEGX,DFEGX,SELFCO,TITLE,COMMAND,STONAM
 
/
=========================== end of LF8R_NEW.UPD =========================
============================ file MATFIT2.UPD ==========================
-  957,  957
290   IF (NIP.NE.NIP1) THEN
- 1185, 1185
290   IF (NIP.NE.NIP1) THEN
- 1202, 1208
      IF (NEXTP(NIP).EQ.NPARS) THEN
         IF (B(NPARS).LE.0.5) THEN
            NIP=NIP-1
C***            PARS(NPARS) = 1.0
            BGCHAR='F'
            GO TO 290
         ELSE
            BGCHAR=' '
         ENDIF
- 1213, 1236
      DO 320 J=1,NIP1
         JJ=NEXTP(J)
         IF (JJ.LE.NPKS.OR.JJ.GE.NPARS) GO TO 320
         IF (NITS.GT.4.AND.DELTA1(JJ)*DELTA(JJ).NE.0.0) THEN
            IF (DELTA(JJ)*DELTA1(JJ).LT.0.0) THEN
               A = SQRT(ABS(DELTA1(JJ)/(DELTA1(JJ)-DELTA(JJ))))
               IF (A.LT.0.7) A=0.7
            ELSEIF (ABS(DELTA(JJ)).LT.ABS(DELTA1(JJ)/2.0)) THEN
               A = SQRT(DELTA1(JJ)/(DELTA1(JJ)-DELTA(JJ)))
            ELSE
               A = 1.414
            ENDIF
            DELTA(JJ) = DELTA(JJ)*A
            B(JJ) = PARS(JJ)+DELTA(JJ)
            FFACT(JJ) = FFACT(JJ)*A
         ENDIF
 
         IF (ABS(DELTA(JJ)).GT.MAXD(JJ)) THEN
               DELTA(JJ)=SIGN(MAXD(JJ),DELTA(JJ))
               B(JJ) = PARS(JJ)+DELTA(JJ)
         ENDIF
320   CONTINUE
- 1693
      IF (NORDER.LE.1) RETURN
/
=========================== end of MATFIT2.UPD =========================
============================ file MFPRINT.UPD ==========================
-   47,   47
5002  CALL ASK2(45HType P/D/S to Print/Delete/Save output file ?,
     +          45,ANS,NC,1)
      IF (NC.EQ.0.OR.ANS(1:1).EQ.'P'.OR.ANS(1:1).EQ.'p') THEN
         CLOSE(UNIT=3,STATUS='PRINT/DELETE')
      ELSEIF (ANS(1:1).EQ.'D'.OR.ANS(1:1).EQ.'d') THEN
         CLOSE(UNIT=3,STATUS='DELETE')
      ELSEIF (ANS(1:1).EQ.'S'.OR.ANS(1:1).EQ.'s') THEN
         CLOSE(UNIT=3)
      ELSE
         GO TO 5002
      ENDIF
-  294,  294
     +       '     Thresholds are',F7.2,' percent and',F7.2' sigma.')
      IF (SYMMAT) WRITE (3,121)
      IF (.NOT.SYMMAT) WRITE (3,122)
121   FORMAT('  Symmetric matrix.'//)
122   FORMAT('  Unsymmetric matrix.'//)
 
-  326
      NABOVET = 0
      NFITTEDP = 0
-  344
            NABOVET = NABOVET + 1
-  359
               NFITTEDP = NFITTEDP + 1
-  401
      WRITE (3,430) NPX,NABOVET,NFITTEDP
430   FORMAT(' '//
     +       '  ***************************************************'/
     +       '  Number of peaks in projection =',I4/
     +       '  Number of coinc. intensities above threshold =',I7/
     +       '  Number of coinc. peaks with fitted energies  =',I7/
     +       '  ***************************************************')
-  408
      IF (SYMMAT) WRITE (3,121)
      IF (.NOT.SYMMAT) WRITE (3,122)
/
=========================== end of MFPRINT.UPD =========================
============================ file MINIG.UPD ==========================
-  797,  798
      J2=I2
      IF (JG(11).EQ.1.AND.I1.NE.0.AND.J2.EQ.0) J2=30
      JY=J2/10
      IY=J2-JY*10
/
=========================== end of MINIG.UPD =========================
============================ file UTIL.UPD ==========================
-    8
C         This version of ASK compares sys$input with sys$output....
C           If they are different, it uses fortran read/write, so that it
C           will work satisfactorily with input from VAX/VMS command
C           files, and in batch mode....      D. Radford  Nov. 1989....
 
-   22
      INTEGER SYS$TRNLOG
      CHARACTER*60 INPUT,OUTPUT
 
 
-   36
      IOK=SYS$TRNLOG('SYS$OUTPUT',,OUTPUT,,,)
      IOK=SYS$TRNLOG('SYS$INPUT',,INPUT,,,)
C***      write (6,*) input
C***      write (6,*) output
C***      write (6,'(z124)') input
C***      write (6,'(z124)') output
-   52,   52
      IF (IR.NE.5
     +     .OR.(INPUT(6:60).NE.OUTPUT(6:60).AND.INPUT(1:2).NE.'TT'))
     +          WRITE(IW,20) CHAR(13)   ! carriage return....
-   58,   58
      IF (IR.NE.5
     +     .OR.(INPUT(6:60).NE.OUTPUT(6:60).AND.INPUT(1:2).NE.'TT'))
     +                      THEN
/
=========================== end of UTIL.UPD =========================
============================ file IRIW.COM ==========================
$ edit/command=iriw ADDMAT.FOR
$ edit/command=iriw CFCOUNT.FOR
$ edit/command=iriw CFPRINT.FOR
$ edit/command=iriw CFTRANS.FOR
$ edit/command=iriw DMERIT.FOR
$ edit/command=iriw DMERIT2.FOR
$ edit/command=iriw DMMAX.FOR
$ edit/command=iriw DMSLICE.FOR
$ edit/command=iriw LF8R_NEW.FOR
$ edit/command=iriw LF8R_OLD.FOR
$ edit/command=iriw MFCOUNT.FOR
$ edit/command=iriw MFPRINT.FOR
$ edit/command=iriw MINIG_GR.FOR
$ edit/command=iriw PRFILE.FOR
$ edit/command=iriw PSLICE.FOR
$ edit/command=iriw SLICE.FOR
$ edit/command=iriw SLICE4.FOR
$ edit/command=iriw SUBBGMAT.FOR
$ edit/command=iriw SYMMAT.FOR
$ edit/command=iriw TRISLI2.FOR
$ edit/command=iriw WIN2TAB.FOR
=========================== end of IRIW.COM =========================
============================ file IRIW.EDT ==========================
su\IR,IW/5,5\IR,IW/5,6\1:1000
su\WRITE(5,\WRITE(6,\1:100000
su\WRITE (5,\WRITE (6,\1:100000
exit
=========================== end of IRIW.EDT =========================
