C N.R.BADNELL 07/08/13 PROGRAM HMERGE C C MERGE MULTIPLE Hnn.DAT OR H.DATnnn FILES (n=0,1,2,3...) TO H.DAT C C CAN SELECT A SUBSET OF SYMMETRIES FROM IPWINIT THRU IPWFINAL. C C ALLOWS FOR VARYING LRANG2 FROM NX CODE (K. BUTLER) C C THE H-FILES DO NOT HAVE TO HAVE A HEADER. C IF H/00.DAT/000 HAS A HEADER THEN IT WILL BE USED AND WRITTEN TO H.DAT C IF IT DOES NOT HAVE A HEADER THEN NONE WILL BE WRITTEN TO H.DAT C HOWEVER, IF A SUBSEQUENT FILE DOES HAVE A HEADER THEN ITS VALUE OF C NAST AND LAMAX WILL BE USED TO READ/WRITE THE CHANNELS ARRAY (NCONAT) C AND THE LONG-RANGE COUPLING COEFFICIENTS ARRAY (CF) FOR *ALL* FILES, C SINCE ALL FILES ARE EXAMINED FOR HEADERS BEFORE THE MAIN BODY IS C READ/WRITTEN - THE LAST ONE READ IS USED - NEEDS USER CONSISTENCY! C IF NO H-FILES HAVE A HEADER THEN THE USER MUST SUPPLY NAST (TO ENABLE C READ/WRITE OF NCONAT) AND, OPTIONALLY, LAMAX (DEFAULT=2). C THE OUTPUT FILE WILL HAVE NO HEADER, OF COURSE, THE USER MUST MERGE C ONE EVENTUALLY BEFORE STGF CAN BE RUN. C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE 'PARAM' C PARAMETER (MZLMX= 10) !MULTIPOLES PARAMETER (MZLP1= 87) !L VALUES FOR BUTTLE C PARAMETER (DZERO=0.0D0) C LOGICAL EX C CHARACTER NAME*8, NUM(0:9)*1 C DIMENSION COEFP(3,MZLP1) C COMMON /PW/IPWINIT,IPWFINAL,IPW,NAST,LAMAX,iprint C DATA NUM /'0','1','2','3','4','5','6','7','8','9'/ C NAMELIST/SMERGE/IPWINIT,IPWFINAL,NAST,LAMAX,iprint C OPEN(11,FILE='H.DAT',STATUS='NEW',FORM='UNFORMATTED') C C SOME INITIALIZATIONS C KFLAG=1 !=1 IF K QUAN NUM PRESENT, =0 IF MISSING LRANG2P=0 C DO L=1,MZLP1 DO I=1,3 COEFP(I,L)=DZERO ENDDO ENDDO C IPW=0 IPWINIT=1 IPWFINAL=999 NAST=0 LAMAX=-2 iprint=-1 C INQUIRE(FILE='dhmerge',EXIST=EX) C IF(EX)THEN OPEN(5,FILE='dhmerge') READ(5,SMERGE) ENDIF C NAST0=NAST LAM0=LAMAX IF(LAMAX.LE.0)LAM0=0 LAMAX=999 C C FIRST LOOP OVER ALL FILES READING JUST THE HEADERS TO CONSTRUCT C A GLOBAL LONG-RANGE COEFFP ARRAY AND LRANG2P. THIS ALSO ENABLES C US TO PICK-UP ONE FROM A LATER FILE IF NOT PRESENT ON THE FIRST. C K100=-1 KASE=0 NAME='H00.DAT' INQUIRE(FILE=NAME,EXIST=EX) IF(.NOT.EX)THEN K100=0 NAME='H.DAT000' INQUIRE(FILE=NAME,EXIST=EX) IF(.NOT.EX)STOP 'NEED AT LEAST H00.DAT OR H.DAT000' ENDIF C 1 OPEN(10,FILE=NAME,STATUS='OLD',FORM='UNFORMATTED') KASE=KASE+1 IF(K100.LT.0)THEN NAME='H'//NUM(KASE/10)//NUM(KASE-10*(KASE/10))//'.DAT' ELSE K100=KASE/100 K1=KASE-100*K100 K10=K1/10 K1=K1-10*K10 NAME='H.DAT'//NUM(K100)//NUM(K10)//NUM(K1) ENDIF INQUIRE(FILE=NAME,EXIST=EX) IF(EX)THEN MORE2=1 ELSE MORE2=0 ENDIF C CALL READH(KASE,KFLAG,MORE2,COEFP,LRANG2P) CLOSE(10) C IF(MORE2.LT.0)STOP 'ABNORMAL END ON INPUT HEADER Hmn.DAT' IF(MORE2.GT.0)GO TO 1 C IF(NAST.LE.0)THEN WRITE(6,500) STOP 'NO HEADERS ON ANY Hnn.DAT FILES, USER MUST SET NAST!' ENDIF C IF(NAST0*NAST.NE.NAST0*NAST0)THEN WRITE(6,501)NAST0,NAST ENDIF C IF(LAMAX.EQ.999)THEN !AND TRUST TO LUCK... LAMAX=2 WRITE(6,502)LAMAX ELSEIF(LAM0*LAMAX.GT.LAM0*LAM0)THEN WRITE(6,503)LAM0,LAMAX LAMAX=LAM0 ENDIF C C NOW READ/WRITE THE FULL H.DAT FILES, USING GLOBAL COEFFP, LRANG2P C KASE=0 IF(K100.LT.0)THEN NAME='H00.DAT' ELSE NAME='H.DAT000' ENDIF C 2 OPEN(10,FILE=NAME,STATUS='OLD',FORM='UNFORMATTED') KASE=KASE+1 IF(K100.LT.0)THEN NAME='H'//NUM(KASE/10)//NUM(KASE-10*(KASE/10))//'.DAT' ELSE K100=KASE/100 K1=KASE-100*K100 K10=K1/10 K1=K1-10*K10 NAME='H.DAT'//NUM(K100)//NUM(K10)//NUM(K1) ENDIF INQUIRE(FILE=NAME,EXIST=EX) IF(EX)THEN MORE2=1 ELSE MORE2=0 ENDIF C CALL READS(KASE,KFLAG,MORE2,COEFP,LRANG2P) CLOSE(10) C IF(MORE2.LT.0)STOP 'ABNORMAL END ON INPUT Hmn.DAT' IF(MORE2.GT.0)GO TO 2 C CLOSE(11) STOP 'HMERGE NORMAL END: NEW FILE H.DAT' C 500 FORMAT(///20X,'NO HEADERS ON ANY Hnn.DAT FILES,'/20X, X 'USER MUST SET NAST AND, OPTIONALLY, LAMAX TO ENABLE READS' X /20X,'NO HEADER CAN BE WRITTEN, USER MUST MERGE ONE EVENTUALLY!') 501 FORMAT(///20X,'NOTE: USER INPUT NAST =',I5/20X, X'BUT A VALUE OF NAST =',I5/20X, X'HAS BEEN FOUND ON A HEADER AND WILL BE USED INSTEAD...') 502 FORMAT(///20X,'NO HEADERS ON ANY Hnn.DAT FILES,'/20X, X '*** USING LAMAX =',I3/20X,'USER CAN RE-SET IF SO DESIRED...') 503 FORMAT(///20X,'NOTE: USER INPUT LAMAX =',I3/20X, X'RESTRICTS THE VALUE OF LAMAX =',I3/20X, X'WHICH HAS BEEN FOUND ON A HEADER') C END C*************************************************************** C SUBROUTINE READH(KASE,KFLAG,MORE2,COEFP,LRANG2P) C C READS H.DAT FILE HEADERS AND FORMS GLOBAL COEFP, LRANG2P C (DOES NOT CHECK SUBSEQUENT HEADERS FOR CONSISTANCY!) C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE 'PARAM' PARAMETER (MZLP1= 87) !L VALUES FOR BUTTLE PARAMETER (MZTAR= 500) !TARGET STATES C PARAMETER (DZERO=0.0D0) C LOGICAL EX C DIMENSION ISAT(MZTAR),LAT(MZTAR),NCONAT(MZTAR) DIMENSION COEFF(3,MZLP1),ENAT(MZTAR) DIMENSION COEFP(3,MZLP1) COMMON /PW/IPWINIT,IPWFINAL,IPW,NAST,MLAMRD,iprint C C*************************************************************** C C FIRST READS DATA INDEPENDENT OF SLPI (HEADER) C C THE FOLLOWING DATA ARE READ _ C NZ = NUCLEAR CHARGE C NELC = NUMBER OF ELECTRONS IN TARGET C NAST = NUMBER OF TARGET STATES C LRANG2 = TOTAL NUMBER OF SMALL L VALUES C LAMAX = MAXIMUM LAMBDA FOR MULTIPOLE POTENTIALS C RA = R-MATRIX RADIUS C BSTO = LOGARITHMIC DERIVATIVE C FOR I = 1,NAST - C ENAT(I) = TARGET ENERGIES C LAT(I) = TARGET ORBITAL ANGULAR MOMENTA C ISAT(I) = VALUES OF (2*S+1) FOR TARGET STATES C FOR I = 1,3 AND L = 1,LRANG2 - C COEFF(I,L) = BUTTLE CORRECTION C C*************************************************************** C C FIRST SEE IF WE HAVE A HEADER C READ(10,END=900)IDUM1,IDUM2,NPTY !EOF=>EMPTY FILE, SO SKIP C BACKSPACE(10) IF(NPTY.EQ.0.OR.NPTY.EQ.1)RETURN !I.E. PARITY NO HEADER C C READ AND DIMENSION CHECKS C READ(10,ERR=999)NELC,NZ,LRANG2,LAMAX,NAST,RA,BSTO C IF(MLAMRD.GT.0)MLAMRD=MIN(MLAMRD,LAMAX) C IF(NAST.GT.MZTAR)THEN WRITE(6,510)NAST,MZTAR STOP 'INCREASE MZTAR' ENDIF C READ(10)(ENAT(I),I=1,NAST) READ(10)(LAT(I),I=1,NAST) READ(10)(ISAT(I),I=1,NAST) C IF(LRANG2.LT.0)THEN INQUIRE(FILE='DBUT.DAT',EXIST=EX) IF(EX)STOP X 'DARC H.DAT DETECTED BUT HMERGE NOT CODED FOR DBUT.DAT' LRANG2=-LRANG2 KFLAG=-1 ENDIF C IF(LRANG2.GT.MZLP1)THEN WRITE(6,520)LRANG2,MZLP1 STOP 'INCREASE MZLP1' ENDIF C READ(10)((COEFF(I,L),I=1,3),L=1,LRANG2) C DO L=1, LRANG2 DO I=1,3 IF(COEFF(I,L).NE.DZERO) THEN !MAY NEED TO USE EPSILON... COEFP(I,L)=COEFF(I,L) ENDIF ENDDO ENDDO C LRANG2P=MAX(LRANG2P,LRANG2) C 900 RETURN C 999 MORE2=-666 GO TO 900 C 510 FORMAT(///20X,'TOO MANY TARGET STATES'// X 10X,'VALUE READ FOR NAST IS ',I5// X 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZTAR=',I5//) 520 FORMAT(///20X,'TOO MANNY BUTTLE COEFFICIENTS'// X 10X,'VALUE READ FOR LRANG2 IS ',I3// X 10X,'MAXIMUM VALUE ALLOWED BY DIMENSIONS IS MZLP1=',I5//) C END C*************************************************************** C SUBROUTINE READS(KASE,KFLAG,MORE2,COEFP,LRANG2P) C C READS H.DAT FILE AND WRITES, HEADER KASE=1 ONLY. C (DOES NOT CHECK SUBSEQUENT HEADERS FOR CONSISTANCY!) C USES GLOBAL COEFP AND LRANG2P. C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE 'PARAM' PARAMETER (MZCHF= 2000) !CHANNELS PARAMETER (MZLMX= 10) !MULTIPOLES PARAMETER (MZLP1= 87) !L VALUES FOR BUTTLE PARAMETER (MZMNP= 25000) !R-MATRIX EIGENVALUES PARAMETER (MZTAR= 500) !TARGET STATES C LOGICAL EX C DIMENSION ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR) DIMENSION CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) DIMENSION VALUE(MZMNP),KJ(MZCHF) DIMENSION COEFP(3,MZLP1) CF77 DIMENSION WMAT(MZCHF,MZMNP) !F77 COMMON /PW/IPWINIT,IPWFINAL,IPW,NAST,MLAMRD,iprint ALLOCATABLE WMAT(:,:) !F95 C C*************************************************************** C C FIRST READS DATA INDEPENDENT OF SLPI (HEADER) C C THE FOLLOWING DATA ARE READ _ C NZ = NUCLEAR CHARGE C NELC = NUMBER OF ELECTRONS IN TARGET C NAST = NUMBER OF TARGET STATES C LRANG2 = TOTAL NUMBER OF SMALL L VALUES C LAMAX = MAXIMUM LAMBDA FOR MULTIPOLE POTENTIALS C RA = R-MATRIX RADIUS C BSTO = LOGARITHMIC DERIVATIVE C FOR I = 1,NAST - C ENAT(I) = TARGET ENERGIES C LAT(I) = TARGET ORBITAL ANGULAR MOMENTA C ISAT(I) = VALUES OF (2*S+1) FOR TARGET STATES C FOR I = 1,3 AND L = 1,LRANG2 - C COEFF(I,L) = BUTTLE CORRECTION C C*************************************************************** C C FIRST SEE IF WE HAVE A HEADER C READ(10,END=900)IDUM1,IDUM2,NPTY !EOF=>EMPTY FILE, SO SKIP C BACKSPACE(10) IF(NPTY.EQ.0.OR.NPTY.EQ.1)GO TO 100 !I.E. PARITY NO HEADER C C READ AND DIMENSION CHECKS C READ(10)NELC,NZ,LRANG2,LAMAX,NAST,RA,BSTO c if(iprint.ge.0)then write(0,*)'kase,nelc,nz,lrang2,lamax,nast,ra,bsto:' write(0,*)kase,nelc,nz,lrang2,lamax,nast,ra,bsto endif C IF(MLAMRD.GT.0)LAMAX=MIN(MLAMRD,LAMAX) IF(LAMAX.GT.MZLMX)THEN MLAMRD=MZLMX WRITE(6,620)LAMAX,MZLMX ELSE MLAMRD=LAMAX ENDIF C IF(KASE.EQ.1) X WRITE(11)NELC,NZ,LRANG2P,MLAMRD,NAST,RA,BSTO !LRANG2->LRANG2P C IF(NAST.GT.MZTAR)THEN WRITE(6,510)NAST,MZTAR STOP 'INCREASE MZTAR' ENDIF C READ(10)(ENAT(I),I=1,NAST) READ(10)(LAT(I),I=1,NAST) READ(10)(ISAT(I),I=1,NAST) C IF(KASE.EQ.1)THEN WRITE(11)(ENAT(I),I=1,NAST) WRITE(11)(LAT(I),I=1,NAST) WRITE(11)(ISAT(I),I=1,NAST) ENDIF C IF(LRANG2.LT.0)THEN INQUIRE(FILE='DBUT.DAT',EXIST=EX) IF(EX)STOP X 'DARC H.DAT DETECTED BUT HMERGE NOT CODED FOR DBUT.DAT' LRANG2=-LRANG2 KFLAG=-1 ENDIF C IF(LRANG2.GT.MZLP1)THEN WRITE(6,520)LRANG2,MZLP1 STOP 'INCREASE MZLP1' ENDIF C READ(10)((COEFF(I,L),I=1,3),L=1,LRANG2) C IF(KASE.EQ.1) X WRITE(11)((COEFP(I,L),I=1,3),L=1,LRANG2P) !COEF->COEFP C C C*************************************************************** C C NOW READ R-MATRIX DATA FOR EACH SLPI CASE C C THE FOLLOWING DATA ARE READ - C LRGL2 = TOTAL ORBITAL ANGULAR MOMENTUM C NSPN2 = TOTAL (2*S+1) C NPTY2 = TOTAL PARITY C NCHAN = NUMBER OF CHANNELS C MNP2 = NUMBER OF R-MATRIX POLES C MORE2 = ZERO TO TERMINATE SLPI CASES C FOR I = 1,NAST - C NCONAT(I) = NUMBER OF CHANNELS FOR TARGET STATE I C FOR I = 1,NCHAN - C L2P(I), KJ(I) = SMALL L AND BIG K FOR CHANNEL I C FOR I = 1,NCHAN AND N = 1,NCHAN AND M = 1,LAMAX - C CF(I,N,M) = COEFFICIENTS IN MULTIPOLE POTENTIALS C FOR I = 1,MNP2 - C VALUE(I) = R-MATRIX POLE ENERGIES C FOR K = 1,NCHAN AND I = 1,MNP2 - C WMAT(K,I) = R-MATRIX AMPLITUDES C C*************************************************************** C 100 NASTR=NAST MORE2W=1 C C READ AND DIMENSION CHECKS C 1000 CONTINUE C READ(10,END=999)LRGL2,NSPN2,NPTY2,NCHAN,MNP2,MORE2O READ(10)(NCONAT(I),I=1,NASTR) ! NAST? C IPW=IPW+1 EX=IPW.GE.IPWINIT C IF(MORE2.EQ.0)MORE2W=MORE2O IF(IPW.EQ.IPWFINAL)THEN MORE2O=0 MORE2=0 MORE2W=0 ENDIF C IF(EX)THEN if(iprint.ge.0)then write(0,*)'ipw,lrgl2,nspn2,npty2,nchan,mnp2,more2w:' write(0,*)ipw,lrgl2,nspn2,npty2,nchan,mnp2,more2w endif WRITE(11)LRGL2,NSPN2,NPTY2,NCHAN,MNP2,MORE2W WRITE(11)(NCONAT(I),I=1,NASTR) ! NAST? ENDIF C IF(NCHAN.GE.MZCHF)THEN !.GE. FOR SR.LU WRITE(6,600)NSPN2,LRGL2,NPTY2,NCHAN,MZCHF STOP 'INCREASE MZCHF' ENDIF C IF(NSPN2.NE.0)KFLAG=0 IF(EX)THEN IF(KFLAG.EQ.1)THEN READ(10)(L2P(I),I=1,NCHAN),(KJ(I),I=1,NCHAN) WRITE(11)(L2P(I),I=1,NCHAN),(KJ(I),I=1,NCHAN) ELSE READ(10)(L2P(I),I=1,NCHAN) WRITE(11)(L2P(I),I=1,NCHAN) ENDIF ELSE READ(10) ENDIF C IF(MLAMRD.GT.0)THEN IF(EX)THEN READ(10)(((CF(I,N,M),I=1,NCHAN),N=1,NCHAN),M=1,MLAMRD) WRITE(11)(((CF(I,N,M),I=1,NCHAN),N=1,NCHAN),M=1,MLAMRD) ELSE READ(10) ENDIF ENDIF C IF(MNP2.GE.0)THEN IF(EX)THEN CF77 IF(MNP2.GT.MZMNP)THEN !F77 CF77 WRITE(6,610)NSPN2,LRGL2,NPTY2,MNP2,MZMNP !F77 CF77 STOP 'INCREASE MZMNP' !F77 CF77 ENDIF !F77 ALLOCATE (WMAT(NCHAN,MNP2)) !F95 READ(10)(VALUE(I),I=1,MNP2) READ(10)((WMAT(K,I),K=1,NCHAN),I=1,MNP2) WRITE(11)(VALUE(I),I=1,MNP2) WRITE(11)((WMAT(K,I),K=1,NCHAN),I=1,MNP2) DEALLOCATE (WMAT) !F95 ELSE READ(10) READ(10) ENDIF ELSE IF(EX)THEN MNP2=-MNP2 READ(10)(VALUE(I),I=1,MNP2) WRITE(11)(VALUE(I),I=1,MNP2) 13 READ(10)ILOW,IUPPER,NDIV WRITE(11)ILOW,IUPPER,NDIV C ALLOCATE (WMAT(NCHAN,ILOW:IUPPER)) !F95 READ(10)((WMAT(K,I),K=1,NCHAN),I=ILOW,IUPPER) !F95 WRITE(11)((WMAT(K,I),K=1,NCHAN),I=ILOW,IUPPER) !F95 DEALLOCATE (WMAT) !F95 C CF77 KK=IUPPER-ILOW+1 !F77 CF77 IF(KK.GT.MZMNP)THEN !F77 CF77 WRITE(6,610)NSPN2,LRGL2,NPTY2,KK,MZMNP !F77 CF77 STOP 'INCREASE MZMNP' !F77 CF77 ENDIF !F77 CF77 READ(10)((WMAT(K,I),K=1,NCHAN),I=1,KK) !F77 CF77 WRITE(11)((WMAT(K,I),K=1,NCHAN),I=1,KK) !F77 C IF(ILOW.NE.1) GO TO 13 ELSE READ(10) 14 READ(10)ILOW,IUPPER,NDIV READ(10) IF(ILOW.NE.1) GO TO 14 ENDIF ENDIF C IF(MORE2O.GT.0)GO TO 1000 RETURN C 999 CONTINUE C C IF WE EXPECT MORE2O TO ALWAYS TERMINATE, I.E. EACH FILE IS COMPLETE C MORE2=-777 ! c IF WE EXPECT EOF TO TERMINATE AS EXPECT MORE (INCOMPLETE) FILES IF(MORE2.EQ.0)THEN !NO MORE TO COME, CASE NOT ALL STG2H READ WRITE(0,*)'*** ATTENTION: SET IPWFINAL=',IPW X ,' TO WRITE MORE=0 ON H.DAT (NONE ON INPUT Hnm.DAT)' ENDIF C 900 RETURN C 510 FORMAT(///20X,'TOO MANY TARGET STATES'// X 10X,'VALUE READ FOR NAST IS ',I5// X 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZTAR=',I5//) 520 FORMAT(///20X,'TOO MANNY BUTTLE COEFFICIENTS'// X 10X,'VALUE READ FOR LRANG2 IS ',I3// X 10X,'MAXIMUM VALUE ALLOWED BY DIMENSIONS IS MZLP1=',I5//) 600 FORMAT(///20X,'TOO MANY CHANNELS FOR (IS, IL, IP) = (', X 3I3,')'//10X,'VALUE READ FOR NCHAN IS ',I5// X 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZCHF=',I5//) CF77 610 FORMAT(///20X,'TOO MANY R-MATRIX STATES FOR (IS, IL, IP)',!F77 CF77 X' = (',3I3,')'//10X,'VALUE READ FOR MNP2 IS ',I6// !F77 CF77 X 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZMNP=',I6//) !F77 620 FORMAT(///20X,'WARNING TOO MANY MULTIPOLES REQUESTED VIZ.',I5// X 20X,'REDUCING TO MAXIMUM ALLOWED BY DIMENSIONS MZLMX=',I5//) C END