DataMuseum.dk

top - metrics - download

    Length: 3840 (0xf00)
    Types: TextFile
    Names: »cpc1«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦this⟧ »cpc1« 

TextFile

c
c    cpc1
c
c    abkd ritz combination principle. program for fitting transition
c    energies into a level according to the combination principle.
c    williams, i.r.
c    ref. in comp. phys. commun. 1 (1970) 465
C
      program ritz
C        PROGRAM TO FIND ENERGY LEVELS
C          (UTILISING THE RITZ COMBINATION PRINCIPLE).
C        TO RUN ON THE ORNL IBM 360/91
C
C
      REAL LEVEL(100)
      DIMENSION GAMMA(300)
C
C        READ BEGINNING ENERGY E,      DECREMENTAL ENERGY DELTE,
C             NUMBER OF STEPS NITER,   UNCERTAINTY IN LEVEL ENERGY DLVL,
C             NUMBER OF GAMMAS NGAMA,  UNCERTAINTY IN GAMMA ENERGY DGAM,
C             NUMBER OF LEVELS NLEVL,        . . . ALL ON ONE DATA CARD.
C        READ GAMMA(I) FROM NEXT CARDS
C        READ LEVEL(J) FROM FINAL CARDS
c     
c     set input and output channels
c
      zone readf(128,1,stderror)
      zone writef(128,1,stderror)
      call zassign(readf,1)
      call zassign(writef,7)
      call open(readf,4,'inf',0)
      call open(writef,4,'outf',0)
      iread=1
      iwrite=7
c
C
      READ (iread,1)  E,DELTE,NITER,NGAMA,NLEVL,DLVL,DGAM
    1 FORMAT (2F6.2,3I6,2F6.2)
      READ (iread,2)  (GAMMA(I),I=1,NGAMA)
      READ (iread,2)  (LEVEL(J),J=1,NLEVL)
    2 FORMAT (12F6.1)
      WRITE (iwrite,3)  E,DELTE,NITER,NGAMA,NLEVL,DLVL,DGAM,(LEVEL(J),
     1   J=1,NLEVL)
    3 FORMAT (1H1,41H   E       DELTE   NITER   NGAMMA  NLEVEL,
     1 15h   DLVL   DGAM ,//2F8.1,3I8,2F8.1///16H ENERGY LEVELS  //,
     2 (12f8.1/))
      WRITE (iwrite,4) (GAMMA(I),I=1,NGAMA)
    4 FORMAT (///17H PHOTON ENERGIES //(12F8.1/))
      WRITE (iwrite,7)
    7 FORMAT (1H ,//31H     E    LEVEL      LEVEL(K) +,17X,9HLEVEL(KJ),
     12h -,16X,11HGAMMA(IJ) +,/27X,8HGAMMA(L),17X,9HGAMMA(LI),18X,
     29hGAMMA(II),/)
C
C        DOES E EQUAL A LEVEL ENERGY
C
      N = 1
   20 M = 0
      DO 30 J = 1,NLEVL
      IF (E - LEVEL(J) - DLVL)40,40,30
   40 IF (E - LEVEL(J) + DLVL)30,60,60
   30 CONTINUE
      WRITE (iwrite,45) E
   45 FORMAT (F8.1)
      GO TO 100
   60 M = M + 1
      WRITE (iwrite,64) E,LEVEL(J)
   64 FORMAT (2F8.1)
  100 CONTINUE
C
C        DOES E = LEVEL(K) + GAMMA(L)
C
      DO 200 K = 1,NLEVL
      DO 200 L = 1,NGAMA
      IF (E - LEVEL(K)-DLVL - GAMMA(L)-DGAM)170,170,200
  170 IF (E - LEVEL(K)+DLVL - GAMMA(L)+DGAM)200,190,190
  190 IF (M - 1)198,196,198
  196 W = LEVEL(J) - LEVEL(K) - GAMMA(L)
      WRITE (iwrite,197) LEVEL(K),GAMMA(L),W
  197 FORMAT (19X,F8.1,2H +,F7.1,2X,1H(,F5.2,1H))
      GO TO 200
  198 WRITE (iwrite,199) LEVEL(K),GAMMA(L)
  199 FORMAT (19X,F8.1,2H +,F7.1)
  200 CONTINUE
C
C        DOES E = LEVEL(KJ) - GAMMA(LI)
C
      DO 300 KJ = 1,NLEVL
      DO 300 LI = 1,NGAMA
      IF (E - LEVEL(KJ)-DLVL + GAMMA(LI)-DGAM)270,270,300
  270 IF (E - LEVEL(KJ)+DLVL + GAMMA(LI)+DGAM)300,290,290
  290 IF (M - 1)298,296,298
  296 X = LEVEL(J) - LEVEL(KJ) + GAMMA(LI)
      WRITE (iwrite,297) LEVEL(KJ),GAMMA(LI),X
  297 FORMAT (45X,F8.1,2H -,F7.1,2X,1H(,F5.2,1H))
      GO TO 300
  298 WRITE (iwrite,299) LEVEL(KJ),GAMMA(LI)
  299 FORMAT (45X,F8.1,2H -,F7.1)
  300 CONTINUE
C
C        DOES E = GAMMA(II) + GAMMA(IJ)
C
      DO 400 IJ = 1,NGAMA
      IJ1 = IJ + 1
      DO 400 II = IJ1,NGAMA
      IF (E - GAMMA(II)-DGAM - GAMMA(IJ)-DGAM)370,370,400
  370 IF (E - GAMMA(II)+DGAM - GAMMA(IJ)+DGAM)400,390,390
  390 IF (M - 1)398,396,398
  396 Y = LEVEL(J) - GAMMA(IJ) - GAMMA(II)
      WRITE (iwrite,397) GAMMA(IJ),GAMMA(II),Y
  397 FORMAT (72X,F8.1,2H +,F7.1,2X,1H(,F5.2,1H))
      GO TO 400
  398 WRITE (iwrite,399) GAMMA(IJ),GAMMA(II)
  399 FORMAT (72X,F8.1,2H +,F7.1)
  400 CONTINUE
C
      E = E - DELTE
      N = N + 1
      IF (N - NITER) 20,20,500
  500 continue
999   format(/a3)
      endoffile=25.shift.16+25.shift.8+25
      write(writef,999) endoffile
      call close(writef,.true.)
      stop
      END
▶EOF◀