C N. R. BADNELL PROGRAM ADF04MRGUP 28/10/19 C PROGRAM MAIN IMPLICIT REAL*8(A-H,O-Z) C C SUPPLEMENTS THE UPSILON DATA FOR EXISTING TRANSITIONS IN ONE C ADF04_1 FILE (E.G. R-MATRIX) WITH DATA FOR TRANSITIONS INVOLVING C *HIGHER* LEVELS FROM A SECOND ADF04_2 FILE (E.G. AUTOSTRUCTURE), C ONLY RUDIMENTARY COMPATIBILITY CHECKS ARE MADE VIZ. C NUCLEAR CHARGE, RESIDUAL CHARGE. C ***NOT*** COMPARED ARE CONFIGS, WEIGHTS OR ENERGIES. C ***ALSO*** IT IS ASSUMED THAT THE N LEVELS IN FILE 1 C CORRESPOND TO THE *FIRST* N LEVELS IN FILE 2. C HOWEVER, IF THE LEVEL ORDERING IN FILE 1 DIFFERS FROM FILE 2 C THE LEVEL INDEX IN FILE 1 CAN BE CHANGED BY THE USER TO ITS C VALUE IN FILE 2. THE RATES ARE MAPPED ACCORDINGLY. C *** THIS IS REALLY TO HANDLE "SMALL" STRUCTURE DIFFERENCES C BETWEEN THE TWO FILES THAT CAN RESULT IN CLOSELY SPACED LEVELS C BEING ORDERED DIFFERENTLY. IT IS *NOT* MEANT TO BE USED TO C IMPOSE A "BETTER" STRUCTURE FROM FILE 2 ON FILE 1, AS THE C RATES AND COLLISION DATA IN FILE 1 ARE NOT ALTERED. C ALL TEMPS IN FILE1 MUST EXIST IN FILE2, BUT FILE2 CAN HAVE C ADDITIONAL TEMPS - THESE ARE IGNORED. C PARAMETER (NTMP=22) PARAMETER (NLEV=1000) C PARAMETER (DZERO=0.0) PARAMETER (DONE=1.0) PARAMETER (DTEN=10.0) C CHARACTER*5 CHAR1,CHAR2 CHARACTER*210 CARD,F200,F300,F350 C REAL*8 MANT1(NTMP+1),MANT2(NTMP+1) C CHARACTER CMANT(NTMP+2)*5,CEXP(NTMP+2)*3 C DIMENSION IEXP1(NTMP+1),IEXP2(NTMP+1),ITEMP2(NTMP+1) DIMENSION W1(NLEV),JORIG(NLEV),KORIG(NLEV) C OPEN(1,FILE='adf04_1',STATUS='OLD') OPEN(2,FILE='adf04_2',STATUS='OLD') C OPEN(7,FILE='adf04mrgup.out',STATUS='UNKNOWN') OPEN(8,FILE='adf04_up',STATUS='UNKNOWN') OPEN(9,STATUS='SCRATCH') C NTMP1=0 C c WRITE(*,*)'ENTER MAX NO. OF TEMPS IN adf04_1,2 FILES,' c X,' <= 0 FOR DEFAULT (14):' c READ(*,*)NTMP1 C IF(NTMP1.LE.0)NTMP1=14 IF(NTMP1.GT.NTMP)THEN WRITE(*,*) 'INCREASE DIMENSION NTMP TO: ',NTMP1 STOP 'INCREASE DIMENSION NTMP' ENDIF IF(NTMP1.GT.22.)STOP'CANNOT MERGE MORE THAN 22 TEMPS!' NTMP2=NTMP1 C READ(1,100)CHAR1,NZED1,NELC1 READ(2,100)CHAR2,NZED2,NELC2 C IF(NZED1.NE.NZED2.OR.NELC1.NE.NELC2)THEN WRITE(*,*)'***ERROR, TRYING TO MERGE INCOMPATIBLE ADF04 FILES:' WRITE(*,*)'NZ1,NE1,NZ2,NE2=' WRITE(*,*)NZED1,NELC1,NZED2,NELC2 STOP'SAYONARA' ENDIF C BACKSPACE(2) READ(2,400)CARD WRITE(8,400)CARD C DO I=1,NLEV KORIG(I)=0 ENDDO C LEV1=0 DO I=1,10000 READ(1,450)LEV,W IF(LEV.EQ.-1)GO TO 10 W1(I)=W+W+DONE JORIG(I)=LEV KORIG(LEV)=I LEV1=LEV1+1 ENDDO 10 LEV2=0 DO I=1,10000 READ(2,*)LEV IF(LEV.EQ.-1)GO TO 20 BACKSPACE(2) READ(2,400)CARD WRITE(8,400)CARD LEV2=LEV2+1 ENDDO C 20 BACKSPACE(2) READ(2,400)CARD WRITE(8,400)CARD C IF(LEV1.GT.LEV2)THEN WRITE(*,*)'TRYING TO MERGE INCOMPATIBLE ADF04 FILES: LEVELS' WRITE(*,*)LEV1,LEV2 STOP 'TRYING TO COMPARE INCOMPATIBLE ADF04 FILES: LEVELS' ENDIF C IF(LEV2.GT.NLEV)THEN WRITE(*,*)'TOO MANY LEVELS, INCREASE NLEV TO: ',LEV2 STOP 'TOO MANY LEVELS' ENDIF C IF(LEV2.LT.1000)THEN F200='(F5.2,I5,6X,20(F5.2,I3))' F300='(2I4,F5.2,I3,23(A5,A3))' F350='(2I4,24(A5,A3))' ELSE F200='(F5.2,I5,8X,20(F5.2,I3))' F300='(2I5,F5.2,I3,23(A5,A3))' F350='(2I5,24(A5,A3))' ENDIF C READ(1,F200)DUM,IDUM,(MANT1(I),IEXP1(I),I=1,NTMP1) C DO I=1,NTMP1 IF(MANT1(I).EQ.DZERO)THEN NTEMP1=I-1 GO TO 30 ENDIF ENDDO NTEMP1=NTMP1 C 30 READ(2,F200)DUM,IDUM,(MANT2(I),IEXP2(I),I=1,NTMP2) C NTEMP2=NTMP2 DO I=1,NTEMP2 IF(MANT2(I).EQ.DZERO)THEN NTMP2=I-1 GO TO 35 ENDIF ENDDO NTMP2=NTEMP2 35 NTEMP2=1 DO I=1,NTMP2 IF(MANT1(NTEMP2).EQ.MANT2(I).AND.IEXP1(NTEMP2).EQ.IEXP2(I))THEN ITEMP2(NTEMP2)=I NTEMP2=NTEMP2+1 ENDIF ENDDO NTEMP2=NTEMP2-1 IF(NTEMP2.NE.NTEMP1)THEN WRITE(*,*)'INCONSISTENT TEMPS ON TWO ADF04 FILES:' WRITE(*,*)'FILE1:',NTEMP1 DO I=1,NTEMP1 WRITE(*,*)MANT1(I),IEXP1(I) ENDDO WRITE(*,*)' ' WRITE(*,*)'FILE2:',NTEMP2,NTMP2 DO I=1,NTMP2 WRITE(*,*)MANT2(I),IEXP2(I) ENDDO STOP'INCONSISTENT TEMPS ON TWO ADF04 FILES' ENDIF C BACKSPACE(1) READ(1,400)CARD WRITE(8,400)CARD C 40 READ(1,F300)IF1,II1,DUM1,IDUM1,(CMANT(I),CEXP(I),I=2,NTMP1+2) IF(IF1.GT.LEV1)GO TO 40 IF(IF1.EQ.-1)GO TO 50 C II2=JORIG(II1) IF2=JORIG(IF1) IF((IF2-II2)*(IF1-II1).LT.0)THEN W=W1(MAX0(II1,IF1))/W1(MIN0(II1,IF1)) II1=IF2 IF1=II2 ELSE W=1.0D0 II1=II2 IF1=IF2 ENDIF T=W*DUM1*DTEN**IDUM1 C REWIND(9) WRITE(9,250)T REWIND(9) READ(9,260)CMANT(1),CEXP(1) C WRITE(8,F350)IF1,II1,(CMANT(I),CEXP(I),I=1,NTMP1+2) GO TO 40 C 50 READ(2,F350)IF2,II2,(CMANT(I),CEXP(I),I=1,NTMP2+2) IF(IF2.EQ.-1)GO TO 60 IF(IF2.GT.LEV2)GO TO 50 II1=KORIG(II2) IF1=KORIG(IF2) IF(IF1*II1.EQ.0)THEN !NOT IN FILE1 DO I0=1,NTEMP2 I=ITEMP2(I0) CMANT(I0+1)=CMANT(I+1) CEXP(I0+1)=CEXP(I+1) ENDDO CMANT(NTEMP2+2)=CMANT(NTMP2+2) CEXP(NTEMP2+2)=CEXP(NTMP2+2) C WRITE(8,F350)IF2,II2,(CMANT(I),CEXP(I),I=1,NTEMP2+2) ENDIF GO TO 50 C 60 BACKSPACE(1) 65 READ(1,400,END=70)CARD WRITE(8,400)CARD GO TO 65 C 70 WRITE(8,500) READ(2,*) 75 READ(2,400,END=80)CARD WRITE(8,400)CARD GO TO 75 C 80 CONTINUE C WRITE(*,*)'NORMAL END, MERGED FILE: adf04_up' C 100 FORMAT(A5,2I10) C 200 FORMAT(F5.2,I5,6X,23(F5.2,I3)) 250 FORMAT(24(1PE9.2)) 260 FORMAT(24(A5,1X,A3)) C 300 FORMAT(2I4,F5.2,I3,23(A5,A3)) C 350 FORMAT(2I4,24(A5,A3)) 400 FORMAT(A210) 450 FORMAT(I5,24X,F4.1) !NOT CA 500 FORMAT('C'/'C',1X,'...HAS BEEN MERGED WITH...'/'C') C END