From 61e13973ed4817bdd7dbd8fdc8cf6346360ef0ba Mon Sep 17 00:00:00 2001 From: Yanting Li <82520809+Yanting126@users.noreply.github.com> Date: Mon, 17 Apr 2023 15:11:32 +0200 Subject: [PATCH 1/5] First version of RFINETUNE A code for fine-tuning diagonal matrix elements in RCI calculations. --- src/tool/BUILDCONF.sh | 1 + src/tool/fical.f90 | 0 src/tool/rfinetune.f90 | 666 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 667 insertions(+) mode change 100755 => 100644 src/tool/fical.f90 create mode 100644 src/tool/rfinetune.f90 diff --git a/src/tool/BUILDCONF.sh b/src/tool/BUILDCONF.sh index e6cf71fd..19de41eb 100644 --- a/src/tool/BUILDCONF.sh +++ b/src/tool/BUILDCONF.sh @@ -29,6 +29,7 @@ rwfnrotate wfnplot rwfntotxt fical +rfinetune " # rcsfratip was not being compiled in the original ${MAKEFILE} for some reason. diff --git a/src/tool/fical.f90 b/src/tool/fical.f90 old mode 100755 new mode 100644 diff --git a/src/tool/rfinetune.f90 b/src/tool/rfinetune.f90 new file mode 100644 index 00000000..4da12095 --- /dev/null +++ b/src/tool/rfinetune.f90 @@ -0,0 +1,666 @@ +!*********************************************************************** + PROGRAM rfinetune +! +! This program fine-tune the Hamiltonian matrix from rci(rci_mpi) program +! +! 1)Read the Hamiltonian matrix of jj-coupling from rcixxx.res +! 2)Extract the part belonging to the MR +! 3)Transform only this part to LSJ-coupling +! 4)Fine-tune the Hamiltonian matrix of LSJ-coupling +! 5)Transform back to jj-coupling +! 6)Create rcixxx.resnew to replace the fine-tuned part of rcixxx.res +! +! Variables: +! H_jj -- Hamiltonian matrix of jj-coupling +! H_LSJ -- Hamiltonian matrix of LSJ-coupling +! Tmatrix -- Transformation matrix get from +! jj2lsj_2022 by Gediminas Gaigalas +! I_num -- The number of CSFs in MR +! ind -- Number of disk files rcixxx.res, ind = NPROCS +! Nres= MYID +! ELSTO2 -- ELSTO in node-0 +! In rci_mpi, only node-0 has the correct, non-zero elsto. +! +! +! Writen by Yanting Li 30/1/2022 +! +!*********************************************************************** + USE vast_kind_param, ONLY: DOUBLE + USE parameter_def, ONLY: NNNP + + IMPLICIT NONE + + CHARACTER(LEN=6) :: STRING + CHARACTER(LEN=128) :: NAME + CHARACTER(LEN=8) :: G92MIX + CHARACTER :: String2*18 + CHARACTER*300 :: line1,line2 + CHARACTER*500 :: dirstring, DEFNAM, DEFNAMNEW + CHARACTER :: RECORD*15, S_orbitals*1070 + CHARACTER (LEN = 3) :: idstring + CHARACTER (LEN = 1) :: transflag + + INTEGER :: I, J, IOS, IR, ind, Nres, nres0 + INTEGER :: IMCDF, IMCDFNEW, NELECR, NCFRES, NWRES, NBLOCKRES, NPARM, N + INTEGER :: NNUC, NBLOCK, NW + INTEGER :: NP10, NCF, ICCUT, MYID, NPROCS, NELC, JBLOCK + INTEGER :: LENNAME, IERR, NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM, JBDUM,& + NCFINBLKDUM, NEVINBLKDUM, IATJPDUM, IDUM, LS_number, jj_number + INTEGER :: ijj, iLS, JB, ii, jj, K, nfine, l, ll, JC, JR, NELC2 + INTEGER :: I_num, Irest + REAL(DOUBLE) :: wa_transformation, conv, Ediff + INTEGER, ALLOCATABLE :: ICCUTBLK(:), MF(:), IROW(:) + INTEGER, ALLOCATABLE :: INELC(:), IROWSAV(:,:) + + DOUBLE PRECISION :: Z, EMN, C, WFACT, RNT, H, HP, ELSTO, ELSTO2 + DOUBLE PRECISION, ALLOCATABLE :: PARM(:), ZZ(:), R(:), RP(:), RPOR(:) + DOUBLE PRECISION, ALLOCATABLE :: E(:), GAMA(:), PZ(:),EMT(:),EMTNEW(:) + DOUBLE PRECISION, ALLOCATABLE :: PF(:,:), QF(:,:), H_JJ(:,:), H_LSJ(:,:) + DOUBLE PRECISION, ALLOCATABLE :: Tmatrix(:,:) + + LOGICAL :: LFORDR, LTRANS, LVP, LNMS, LSMS, FOUND + + conv = 2.1947463136320e5 + OPEN(UNIT=215,FILE='rfinetune.log',STATUS='UNKNOWN') + + WRITE (*,*) '****************************************************' + WRITE (*,*) 'RFINETUNE' + WRITE (*,*) 'This is the rfinetune program' + WRITE (*,*) 'Input files: rci.res, name.lsj.T, name.lsj.c,name.c' + WRITE (*,*) 'Output files: rci.resnew' + WRITE (*,*) '****************************************************' +! Ask about transformation matrix from serial calculation or parallel + WRITE (*,*) 'Transformation matrix is from calculation of:' + WRITE (*,*) '0--serial' + WRITE (*,*) '1--parallel' + READ (*,*) transflag + WRITE(215,*) transflag + IF (transflag .NE. '0' .AND. transflag .NE. '1') THEN + WRITE(*,*) 'Your input must be "0" or "1". Try again!' + STOP + ENDIF +! ---------G.G: Read the transformation file .lsj.T -------------- +! + WRITE(*,*) 'Name of MR state: ' + READ(*,*) NAME + LENNAME = LEN_TRIM(NAME) + WRITE(215,'(A)') NAME(1:LENNAME) + OPEN(59,FILE=name(1:LENNAME)//'.lsj.T',FORM='UNFORMATTED'& + ,STATUS='OLD',IOSTAT=IERR) + if (ierr /= 0) then + print *, 'Error when opening ',name, '.lsj.T' + stop + end if + OPEN(95,FILE=name(1:LENNAME)//'.lsj.c',FORM='FORMATTED'& + ,STATUS='OLD',IOSTAT=IERR) + if (ierr /= 0) then + print *, 'Error when opening ',name, '.lsj.c' + stop + end if +! * * * + READ (59, IOSTAT=IERR) G92MIX + read (59) NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + !if(NELECDUM /= NELECR .or. NCFTOTDUM /= NCFRES .or. NWDUM /= NW + !& + ! .or. NBLOCKDUM /= NBLOCK) then + ! print*, NELECR, NCFRES, NW, NBLOCK + ! print*, NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + ! print*, "Wrong transformation file *.lsj.T" + ! close(59) + ! stop + !end if + do JB = 1, NBLOCKDUM + !IATJPDUM = ITJPO(JB) + read (59) JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + if (JBDUM /= JB) then + print*, JB,JBDUM + print*, "Wrong transformation file *.lsj.T" + close(59) + stop + end if + end do +! The head of name.lsj.c + read(95,*) + read(95,*) +! Read the MR CSFs list name.c, obtain the number of CSFs I_num + OPEN(21,FILE=name(1:LENNAME)//'.c',FORM='FORMATTED'& + ,STATUS='OLD',IOSTAT=IERR) + read(21,'(1A15)')RECORD + IF ( RECORD(1:15)/='Core subshells:') THEN + WRITE (*, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF + read(21,'(A)') + read(21,'(A)') + read(21,'(A)') + read(21,'(A)') + +! rci.res from parallel calculation... + IF (transflag == '1') THEN + WRITE (*,*) 'Transformation matrix is from parallel& + calculation...' +! dirstring = '/home/ytli/tmp/' + WRITE(*,*) 'Name of the temporary directory: (e.g.',"'",& + '/home/user/tmp/',"'",')' + READ(*,*) dirstring + WRITE(215,'(a1, A, a1)') "'", trim(dirstring), "'" +! ------Inquire and read rcixxx.res---- + ind = 0 + DO + WRITE (idstring, '(I3.3)') ind + DEFNAM = trim(dirstring)// idstring //& + '/rci' // idstring // '.res' + DEFNAMNEW = trim(dirstring)// idstring //& + '/rci' // idstring // '.resnew' + INQUIRE(FILE=DEFNAM, EXIST=FOUND) + IF ( FOUND ) THEN + IMCDF = 99 + ind + IMCDFNEW = 599 + ind +! Open rcixxx.res and rcixxx.resnew + OPEN(UNIT=IMCDF,FILE=DEFNAM,FORM='UNFORMATTED',STATUS='OLD') + OPEN(UNIT=IMCDFNEW,FILE=DEFNAMNEW,FORM='UNFORMATTED',& + STATUS='UNKNOWN') +! --------- THESE READ STATEMENTS ARE FROM LODRES -------------- +! Read the header and check correctness + READ(IMCDF) STRING + WRITE(IMCDFNEW) STRING + IF (STRING.NE.'R92RES') THEN + WRITE(*,*) 'Not an rci.res file' + STOP + END IF +! Read the basic parameters of the electron cloud + READ(IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES + WRITE(IMCDFNEW) NELECR, NCFRES, NWRES, NBLOCKRES + NBLOCK = NBLOCKRES ! If a complete run then these are equal + NW = NWRES ! +! Read the nuclear parameters + READ(IMCDF) Z, EMN + WRITE(IMCDFNEW) Z, EMN + ALLOCATE(PARM(10)) + READ(IMCDF) NPARM, (PARM(I),I=1,NPARM) + WRITE(IMCDFNEW) NPARM, (PARM(I),I=1,NPARM) + ALLOCATE(ZZ(10000)) + READ(IMCDF) N, (ZZ(I),I=1,N), NNUC + WRITE(IMCDFNEW) N, (ZZ(I),I=1,N), NNUC + ALLOCATE(ICCUTBLK(NBLOCK)) +! Read the physical effects specifications +! iccutblk() is now an array of length nblock. + READ(IMCDF) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, & + WFACT, LVP, LNMS, LSMS + WRITE(IMCDFNEW) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS,& + WFACT, LVP, LNMS, LSMS +! Read the remaining parameters controlling the radial grid and the +! grid arrays + NP10 = N + 10 + ALLOCATE(R(NP10)) + ALLOCATE(RP(NP10)) + ALLOCATE(RPOR(NP10)) + READ(IMCDF) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), & + (RPOR(I),I=1,NP10) + WRITE(IMCDFNEW) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), & + (RPOR(I),I=1,NP10) +! Read the orbital wavefunctions and the associated arrays + ALLOCATE(E(NW)) + ALLOCATE(GAMA(NW)) + ALLOCATE(PZ(NW)) + ALLOCATE(MF(NW)) + ALLOCATE(PF(NNNP,NW)) + ALLOCATE(QF(NNNP,NW)) + DO J = 1, NW + READ(IMCDF) E(J), GAMA(J), PZ(J), MF(J) + WRITE(IMCDFNEW) E(J), GAMA(J), PZ(J), MF(J) + READ(IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + WRITE(IMCDFNEW) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + END DO + DEALLOCATE(PARM) + DEALLOCATE(ZZ) + DEALLOCATE(ICCUTBLK) + DEALLOCATE(R) + DEALLOCATE(RP) + DEALLOCATE(RPOR) + DEALLOCATE(E) + DEALLOCATE(GAMA) + DEALLOCATE(PZ) + DEALLOCATE(MF) + DEALLOCATE(PF) + DEALLOCATE(QF) + ind = ind + 1 + ELSE + GOTO 73 + ENDIF + ENDDO +! +! Print on screen +! + 73 WRITE(*,*) 'There are ', ind, 'files in the temp & + directory...' +! +! Loop over block + DO JBLOCK = 1,NBLOCK + WRITE(*,*) 'BLOCK',JBLOCK + I_num = 0 + DO + read(21,'(A)', end=16) S_orbitals + IF (S_orbitals(1:2) == ' *') GOTO 16 + I_num = I_num + 1 + read(21,'(A)') S_orbitals + read(21,'(A)') S_orbitals + ENDDO + +! Allocate for fine-tuning matrix + 16 ALLOCATE(EMTNEW(I_num*I_num)) + ALLOCATE(H_JJ(I_num,I_num)) + ALLOCATE(H_LSJ(I_num,I_num)) + ALLOCATE(Tmatrix(I_num,I_num)) + ALLOCATE(IROWSAV(I_num,I_num)) + ALLOCATE(INELC(I_num)) + + H_JJ = 0.d0 + H_LSJ = 0.d0 + Tmatrix = 0.d0 +! + read(59) String2, IDUM + if ( String2(1:18) /= ' * Block Number=' .or. IDUM /= jblock) then + print*, "Error in transformation file *.lsj.T" + stop + end if + + do LS_number = 1, I_num + do jj_number = 1, I_num + read(59) ijj, iLS, wa_transformation + if(ijj /= jj_number .or. iLS /= LS_number ) then + print*, "Error in jj2lsj transformation file" + stop + end if + Tmatrix(iLS,ijj) = wa_transformation + end do + end do +! Loop over rcixxx.res to read + DO Nres = 0, ind-1 + IMCDF = 99 + Nres + IMCDFNEW = 599 + Nres + READ(IMCDF, IOSTAT=IOS) NCF, ICCUT, MYID, NPROCS + IF (IOS /= 0) THEN + WRITE(*,*)'READ WRONG IN rci.res, myid=', Nres + ENDIF + WRITE(IMCDFNEW) NCF, ICCUT, MYID, NPROCS + ENDDO +! + ALLOCATE(EMT(2*NCF)) + ALLOCATE(IROW(2*NCF)) +! Loop over rcixxx.res to obtain H_JJ + INELC(:) = 0 + IROWSAV(:,:) = 0 + DO Nres = 0, ind-1 + IF ( Nres .GE. I_num) GOTO 776 + IMCDF = 99 + Nres + IMCDFNEW = 599 + Nres + DO I = Nres + 1, I_num, NPROCS + READ(IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), & + (IROW(IR),IR=1,NELC) + INELC(I) = NELC + IF ( Nres == 0 ) ELSTO2 = ELSTO +! Transfer to dense matrix H_JJ + DO IR = 1, NELC - 1 + H_JJ(I,IROW(IR)) = EMT(IR) + H_JJ(IROW(IR),I) = EMT(IR) + IROWSAV(IR,I) = IROW(IR) + END DO + H_JJ(I,IROW(NELC)) = EMT(NELC) + ELSTO2 + IROWSAV(NELC,I) = IROW(NELC) + END DO + ENDDO +! ------- CREATE H_LSJ ---------------------- + 776 H_LSJ = matmul(matmul(Tmatrix, H_JJ),transpose(Tmatrix)) + !write(*,*)'H_LSJ matrix........' + !Do ii = 1, I_num + ! write(388,*)ii, H_LSJ(ii,:) + !ENDDO +! Read LSJ-coulping CSFs + DO jj = 1,I_num + read(95,'(a)') line1 + if (line1(1:2).eq.' *') then + read(95,'(a)') line1 + endif + read(95,'(a)') line2 + write(*,*) trim(line1) + write(*,*) trim(line2) + ENDDO + +! --------------- FINE-TUNE --------------------------- + 67 write(*,*) 'How many diagonal elements should & + be fine-tuned:' + read(*,*) nfine + WRITE(215,*) nfine + if ( nfine .GT. I_num ) then + write(*,*) 'Please enter a number less than or equal to'& + , I_num + goto 67 + endif +! + DO K = 1, nfine + write(*,*)'Give the serial number of the CSF in LSJ-couping & + you should fine-tune together with the energy change & + in cm-1' + read(*,*)l,Ediff + WRITE(215,'(I3, a1, f9.2)') l, ",", Ediff + H_LSJ(l,l) = H_LSJ(l,l) + Ediff/conv + ENDDO +! + !write(*,*)'H_LSJ matrix after fintuning........' + !Do J = 1, I_num + ! write(389,*)j, H_LSJ(j,:) + !ENDDO +! +! ------------- TRANFORMN BACK TO H_JJ ------ + H_JJ = matmul(matmul(transpose(Tmatrix), H_LSJ),Tmatrix) + !write(*,*)'H_JJ matrix after finetuning........' + !Do ll = 1, I_num + ! write(*,*)ll, H_JJ(ll,:) + !ENDDO + +! -------- SUBTRACT ELSTO AND WRITE TO RCI.RESNEW ------ + DO Nres = 0, ind-1 + IMCDF = 99 + Nres + IMCDFNEW = 599 + Nres +! nres0--count MR for each file + nres0 = 0 + EMTNEW(:) = 0.d0 + IF ( Nres .LT. I_num) THEN + DO JC = Nres + 1, I_num, NPROCS + NELC2 = INELC(JC) + DO JR = 1,NELC2-1 + EMTNEW(JR) = H_JJ(JC,IROWSAV(JR,JC)) + ENDDO + EMTNEW(NELC2) = H_JJ(JC,IROWSAV(NELC2,JC)) - ELSTO2 + + WRITE (IMCDFNEW) NELC2, ELSTO2, (EMTNEW(IR), IR = 1, NELC2),& + (IROWSAV(IR,JC), IR = 1, NELC2) + nres0 = nres0 + 1 + ENDDO +! Copy the rest matrixs from rci.res to rci.resnew + DO Irest = nres0 * ind + Nres + 1, NCF, NPROCS + READ(IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), & + (IROW(IR),IR=1,NELC) + WRITE (IMCDFNEW) NELC, ELSTO, (EMT(IR), IR = 1, NELC),& + (IROW(IR), IR = 1, NELC) + ENDDO + ELSE +! if Nres >= I_num, there is no fine-tuning for this node +! just copy them directly + DO Irest = Nres + 1, NCF, NPROCS + READ(IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), & + (IROW(IR),IR=1,NELC) + WRITE (IMCDFNEW) NELC, ELSTO, (EMT(IR), IR = 1, NELC),& + (IROW(IR), IR = 1, NELC) + END DO + ENDIF + ENDDO + +! Deallocate EMT and IROW + DEALLOCATE(EMT) + DEALLOCATE(EMTNEW) + DEALLOCATE(IROW) + DEALLOCATE(Tmatrix) + DEALLOCATE(H_LSJ) + DEALLOCATE(H_JJ) + DEALLOCATE(IROWSAV) + DEALLOCATE(INELC) + + END DO + + close(21) + close(59) + close(95) + close(215) + DO Nres = 0, ind-1 + IMCDF = 99 + Nres + IMCDFNEW = 599 + Nres + close(IMCDF) + close(IMCDFNEW) + ENDDO + + write(*,*)'Created rcixxx.resnew in ', trim(dirstring) + +! rci.res from serial calculation ... + ELSEIF (transflag == '0') THEN + WRITE (*,*) 'Transformation matrix is from serial & + calculation...' + IMCDF = 26 + IMCDFNEW = 36 + + OPEN(UNIT=IMCDF,FILE='rci.res',FORM='UNFORMATTED',STATUS='OLD') + OPEN(UNIT=IMCDFNEW,FILE='rci.resnew',FORM='UNFORMATTED',STATUS=& + 'UNKNOWN') + +! Read the header and check correctness +! + READ(IMCDF) STRING + WRITE(IMCDFNEW) STRING + IF (STRING.NE.'R92RES') THEN + WRITE(*,*) 'Not an rci.res file' + STOP + END IF +! +! Read the basic parameters of the electron cloud +! + READ(IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES + WRITE(IMCDFNEW) NELECR, NCFRES, NWRES, NBLOCKRES + NBLOCK = NBLOCKRES ! If a complete run then these are equal + NW = NWRES ! +! ------------------------------------------------------------ +! Read the nuclear parameters +! + READ(IMCDF) Z, EMN + WRITE(IMCDFNEW) Z, EMN + !WRITE(*,*) Z, EMN + + ALLOCATE(PARM(10)) + READ(IMCDF) NPARM, (PARM(I),I=1,NPARM) + WRITE(IMCDFNEW) NPARM, (PARM(I),I=1,NPARM) + !WRITE(*,*) NPARM, (PARM(I),I=1,NPARM) + + ALLOCATE(ZZ(10000)) + READ(IMCDF) N, (ZZ(I),I=1,N), NNUC + WRITE(IMCDFNEW) N, (ZZ(I),I=1,N), NNUC + !WRITE(*,*) N, (ZZ(I),I=1,N), NNUC + +! Read the physical effects specifications +! iccutblk() is now an array of length nblock. +! + ALLOCATE(ICCUTBLK(NBLOCK)) + READ(IMCDF) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, WFACT, LVP, & + LNMS, LSMS + WRITE(IMCDFNEW) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, WFACT, LVP, & + LNMS, LSMS + !WRITE(*,*) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, WFACT, + !LVP, & + ! LNMS, LSMS +! +! Read the remaining parameters controlling the radial grid and the +! grid arrays +! + NP10 = N + 10 + ALLOCATE(R(NP10)) + ALLOCATE(RP(NP10)) + ALLOCATE(RPOR(NP10)) + READ(IMCDF) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), & + (RPOR(I),I=1,NP10) + WRITE(IMCDFNEW) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), & + (RPOR(I),I=1,NP10) + +! Read the orbital wavefunctions and the associated arrays +! + + ALLOCATE(E(NW)) + ALLOCATE(GAMA(NW)) + ALLOCATE(PZ(NW)) + ALLOCATE(MF(NW)) + ALLOCATE(PF(NNNP,NW)) + ALLOCATE(QF(NNNP,NW)) + DO J = 1, NW + READ(IMCDF) E(J), GAMA(J), PZ(J), MF(J) + WRITE(IMCDFNEW) E(J), GAMA(J), PZ(J), MF(J) + !WRITE(*,*) E(J), GAMA(J), PZ(J), MF(J) + READ(IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + WRITE(IMCDFNEW) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + !WRITE(*,*) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + END DO +! + DO JBLOCK = 1,NBLOCK + WRITE(*,*) 'BLOCK',JBLOCK +! --------- THESE READ STATEMENTS ARE FROM GENMAT -------------- + READ(IMCDF) NCF, ICCUT, MYID, NPROCS + WRITE(IMCDFNEW) NCF, ICCUT, MYID, NPROCS + I_num = 0 + DO + read(21,'(A)', end=17) S_orbitals + IF (S_orbitals(1:2) == ' *') GOTO 17 + I_num = I_num + 1 + read(21,'(A)') S_orbitals + read(21,'(A)') S_orbitals + ENDDO + write(*,*)'I_num=', I_num + +! We allocate NCF x NCF for EMT and IROW which is more than enough + 17 ALLOCATE(EMT(NCF*NCF)) + ALLOCATE(EMTNEW(I_num*I_num)) + ALLOCATE(IROW(NCF*NCF)) + ALLOCATE(H_JJ(I_num,I_num)) + ALLOCATE(H_LSJ(I_num,I_num)) + ALLOCATE(Tmatrix(I_num,I_num)) + ALLOCATE(IROWSAV(I_num*I_num,I_num)) + ALLOCATE(INELC(I_num)) + + H_JJ = 0.d0 + H_LSJ = 0.d0 + Tmatrix = 0.d0 +! + read(59) String2, IDUM + if ( String2(1:18) /= ' * Block Number=' .or. IDUM /= jblock) then + print*, "Error in transformation file *.lsj.T" + end if + + + do LS_number = 1, I_num + do jj_number = 1, I_num + read(59) ijj, iLS, wa_transformation + if(ijj /= jj_number .or. iLS /= LS_number ) then + print*, "Error in jj2lsj transformation file" + stop + end if + Tmatrix(iLS,ijj) = wa_transformation + end do + end do +! +! + INELC(:) = 0 + IROWSAV(:,:) = 0 + DO I = MYID + 1, I_num, NPROCS + READ(IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), & + (IROW(IR),IR=1,NELC) + INELC(I) = NELC + DO k = 1, NELC + IROWSAV(K,I) = IROW(k) + ENDDO + +! Transfer to dense matrix H_JJ + + DO IR = 1, NELC - 1 + H_JJ(I,IROW(IR)) = EMT(IR) + H_JJ(IROW(IR),I) = EMT(IR) + END DO + H_JJ(I,IROW(NELC)) = EMT(NELC) + ELSTO ! + END DO + +! ------- CREATE H_LSJ ---------------------- + H_LSJ = matmul(matmul(Tmatrix, H_JJ),transpose(Tmatrix)) + !write(*,*)'H_LSJ matrix........' + !Do ii = 1, I_num + ! write(*,*)ii, H_LSJ(ii,:) + !ENDDO +! Read LSJ csl file + DO jj = 1,I_num + read(95,'(a)') line1 + if (line1(1:2).eq.' *') then + read(95,'(a)') line1 + endif + read(95,'(a)') line2 + write(*,*) 'No. in LSJ-couping =', jj + print*, trim(line1) + print*, trim(line2) + ENDDO + +! --------------- FINE TUNE --------------------------- + 68 write(*,*) 'How many diagnoal elements should be & + fine-tuned:' + read(*,*) nfine + WRITE(215,*) nfine + if ( nfine .GT. I_num ) then + write(*,*) 'Please enter a number less than or equal to'& + , I_num + goto 68 + endif +! + DO K = 1, nfine + write(*,*)'Give the serial number of the CSF in LSJ-couping you & + should fine-tune together with the energy change in cm-1' + read(*,*)l,Ediff + WRITE(215,'(I3 a1, f9.2)') l, ",", Ediff + H_LSJ(l,l) = H_LSJ(l,l) + Ediff/conv + ENDDO +! + !write(*,*)'H_LSJ matrix after fintuning........' + !Do J = 1, I_num + ! write(*,*)j, H_LSJ(j,:) + !ENDDO +! +! ------------- TRANFORMN BACK TO H_JJ ------ + H_JJ = matmul(matmul(transpose(Tmatrix), H_LSJ),Tmatrix) + !write(*,*)'H_JJ matrix after finetuning........' + !Do ll = 1, I_num + ! write(*,*)ll, H_JJ(ll,:) + !ENDDO + +! -------- SUBTRACT ELSTO AND WRITE TO RCI.RESNEW ------ + EMTNEW(:) = 0.d0 + DO JC = MYID + 1, I_num, NPROCS + NELC2 = INELC(JC) + DO JR = 1,NELC2-1 + EMTNEW(JR) = H_JJ(JC,IROWSAV(JR,JC)) + ENDDO + EMTNEW(NELC2) = H_JJ(JC,IROWSAV(NELC2,JC)) - ELSTO + WRITE (imcdfnew) NELC2, ELSTO, (EMTNEW(IR), IR = 1, NELC2),& + (IROWSAV(IR,JC), IR = 1, NELC2) + ENDDO +! Copy the rest of matrixs from rci.res to rci.resnew + DO Irest = MYID + I_num + 1, NCF, NPROCS + READ(IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), & + (IROW(IR),IR=1,NELC) + WRITE (imcdfnew) NELC, ELSTO, (EMT(IR), IR = 1, NELC),& + (IROW(IR), IR = 1, NELC) + END DO + + +! Deallocate EMT and IROW + DEALLOCATE(EMT) + DEALLOCATE(EMTNEW) + DEALLOCATE(IROW) + DEALLOCATE(Tmatrix) + DEALLOCATE(H_LSJ) + DEALLOCATE(H_JJ) + DEALLOCATE(IROWSAV) + DEALLOCATE(INELC) + + END DO + close(IMCDF) + close(IMCDFNEW) + close(21) + close(59) + close(95) + close(215) + + write(*,*)'Created rci.resnew' + ENDIF + + END PROGRAM From 44934dcf3c56e65346c23622f6a28d2a0158d46a Mon Sep 17 00:00:00 2001 From: Gediminas Gaigalas Date: Mon, 17 Apr 2023 15:15:02 +0200 Subject: [PATCH 2/5] Adds transformation output for rfinetune --- src/appl/jj2lsj90/jj2lsj2K.f90 | 7 +- src/appl/jj2lsj90/jj2lsj_code.f90 | 137 +++++++++++++++++++++++++++--- 2 files changed, 130 insertions(+), 14 deletions(-) diff --git a/src/appl/jj2lsj90/jj2lsj2K.f90 b/src/appl/jj2lsj90/jj2lsj2K.f90 index c65160f3..9ffc1aac 100644 --- a/src/appl/jj2lsj90/jj2lsj2K.f90 +++ b/src/appl/jj2lsj90/jj2lsj2K.f90 @@ -22,6 +22,7 @@ PROGRAM jj2lsj2K ! VILNIUS May 2017 * ! * ! Modified by G. Gaigalas and C. Cychen 2021 * +! Modified by G. Gaigalas 2022 * ! * !*********************************************************************** !----------------------------------------------- @@ -39,11 +40,13 @@ PROGRAM jj2lsj2K print *, "jj2lsj: Transformation of ASFs from a jj-coupled CSF basis" print *, " into an LS-coupled CSF basis (Fortran 95 version)" print *, " (C) Copyright by G. Gaigalas and Ch. F. Fischer," - print *, " (2021)." + print *, " (2022)." print *, " Input files: name.c, name.(c)m" + print *, " (optional) name.lsj.T" print *, " Ouput files: name.lsj.lbl," print *, " (optional) name.lsj.c, name.lsj.j," - print *, " name.uni.lsj.lbl, name.uni.lsj.sum" + print *, " name.uni.lsj.lbl, name.uni.lsj.sum," + print *, " name.lsj.T" print *, " " ! ! Set up the table of logarithms of factorials diff --git a/src/appl/jj2lsj90/jj2lsj_code.f90 b/src/appl/jj2lsj90/jj2lsj_code.f90 index ca8a49e2..26bd5040 100644 --- a/src/appl/jj2lsj90/jj2lsj_code.f90 +++ b/src/appl/jj2lsj90/jj2lsj_code.f90 @@ -168,7 +168,8 @@ MODULE jj2lsj_code ! !*********************************************************************** ! * - SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) + SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN, & + NCFMAX,ioutT) ! * ! Expands an atomic state functions from the same block, * ! which is represented in a jj-coupling CSF basis into a basis * @@ -178,6 +179,7 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) ! * ! Written by G. Gaigalas, * ! NIST last update: May 2011 * +! Modified by G. Gaigalas 2022 * ! * !*********************************************************************** !----------------------------------------------- @@ -201,20 +203,31 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer, intent(in) :: iw1, levmax,IBLKNUM + integer, intent(in) :: iw1, levmax,IBLKNUM,ioutT integer, intent(in) :: NCFMIN, NCFMAX integer, dimension(:), intent(in) :: ithresh integer, dimension(Blocks_number,Vectors_number), intent(in) :: levels !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: jj_number, lev, level, LS_number - integer :: LOC, IMINCOMP + CHARACTER(LEN=18) :: String + integer :: jj_number, lev, level, LS_number, ijj, iLS + integer :: LOC, IMINCOMP, IDUM real(DOUBLE) :: wa_transformation real(DOUBLE), dimension(Vectors_number) :: wa real(DOUBLE), dimension(Vectors_number) :: wb !----------------------------------------------- wb = zero +!GGR if(ioutT == 1) write(59) ' * Block Number=',IBLKNUM + if(ioutT == 1) write(59,'(A18,I6)') ' * Block Number=',IBLKNUM + if(ioutT == 2) then +!GGR read(59) String, IDUM + read(59,'(A18,I6)') String, IDUM + if(String(1:18) /= ' * Block Number=' .or. & + IDUM /= IBLKNUM) then + print*, "Error in transformation file *.lsj.T" + end if + end if do LS_number = 1, asf_set_LS%csf_set_LS%nocsf if ((asf_set_LS%csf_set_LS%csf(LS_number)%parity == "+" & .and. ISPAR(iw1) == 1) .or. & @@ -225,7 +238,21 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) if(ithresh(jj_number) == 1 .and. & (asf_set_LS%csf_set_LS%csf(LS_number)%totalJ == & ITJPO(jj_number)-1)) then + if(ioutT <= 1) & wa_transformation = traLSjj(jj_number,LS_number) +!GGR if(ioutT == 1) write(59) wa_transformation + if(ioutT == 1) write(59,'(2I6,2X,F16.9)') & + jj_number-NCFMIN+1,LS_number,wa_transformation + if(ioutT == 2) then +!GGR read(59) wa_transformation + read(59,'(2I6,2X,F16.9)') & + ijj, iLS, wa_transformation + if(ijj /= jj_number-NCFMIN+1 .or. & + iLS /= LS_number ) then + print*, "Error in jj2lsj transformation file" + stop + end if + end if do lev = 1,levmax level = levels(IBLKNUM,lev) LOC = (level-1)*NCF @@ -1100,7 +1127,7 @@ END SUBROUTINE gettermLS !*********************************************************************** ! * SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & - UNIQUE) + UNIQUE,ioutT) ! * ! The input from the screen. * ! * @@ -1109,6 +1136,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ! * ! Written by G. Gaigalas, * ! NIST last update: Dec 2015 * +! Modified by G. Gaigalas 2022 * ! * !*********************************************************************** !----------------------------------------------- @@ -1119,23 +1147,27 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & USE PRNT_C, ONLY: NVEC USE IOUNIT_C, ONLY: ISTDI, ISTDE USE CONS_C, ONLY: EPS, ZERO - USE BLK_C, ONLY: NEVINBLK, NBLOCK +!GG USE BLK_C, ONLY: NEVINBLK, NBLOCK + USE BLK_C, ONLY: NEVINBLK, NCFINBLK, NBLOCK, TWO_J USE m_C, ONLY: NCORE USE def_C, ONLY: Z, NELEC IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer, intent(out) :: ioutC,ioutj,UNIQUE + integer, intent(out) :: ioutC,ioutj,UNIQUE,ioutT real(DOUBLE), intent(out) :: THRESH integer, dimension(Blocks_number), intent(out) :: number_of_levels integer, dimension(Blocks_number,Vectors_number), intent(out) :: levels !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: I, II, ISUM, K, NCI, ierr + integer :: NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + integer :: JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + integer :: I, II, ISUM, K, NCI, ierr, JB integer :: IBlock, number_of_levels_tmp logical :: yes, fail, GETYN + CHARACTER(LEN=6) :: G92MIX character(len=24) :: NAME character(len=256) :: record, util_csl_file integer, dimension(Blocks_number) :: posi @@ -1184,6 +1216,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & THRESH = 0.001D00 ioutC = 0 ioutj = 0 + ioutT = 0 DO I = 1, NBLOCK number_of_levels(I) = NEVINBLK(I) IF(NEVINBLK(I) /= 0) THEN @@ -1253,7 +1286,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & WRITE (ISTDE,'(A,F8.5)') ' should be smaller than:',MINCOMP*0.01 READ *, EPSNEW ELSE - WRITE (ISTDE,*) " THe maximum of omitted composition can be 100%" + WRITE (ISTDE,*) " The maximum of omitted composition can be 100%" GO TO 3 END IF WRITE (ISTDE,*) 'What is the value below which an eigenvector composition' @@ -1275,6 +1308,21 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ioutj = 0 END IF END IF + WRITE (ISTDE,*) & + "Do you need the transformation output file *.lsj.T? (y/n)" + YES = GETYN () + IF (YES) THEN + ioutT = 1 + ELSE + WRITE (ISTDE,*) & + "Will you use the transformation file *.lsj.T? (y/n)" + YES = GETYN () + IF (YES) THEN + ioutT = 2 + ELSE + ioutT = 0 + END IF + END IF ENDIF ! WRITE (ISTDE,*) @@ -1335,6 +1383,68 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & WRITE (58,'(2X,A6,A,F5.1,A,I3,A,I7)' ) & NAME(1:K-1),' Z = ',Z ,' NEL = ',NELEC,' NCFG ='! ,asf_set_LS%csf_set_LS%nocsf ENDIF +! +! Opening the files *.lsj.T and +! + IF(ioutT == 1) THEN + util_csl_file = NAME(1:K-1)//'.lsj'//'.T' +!GGR OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='NEW', & + OPEN(59,FILE=util_csl_file,FORM='formatted',STATUS='NEW', & + IOSTAT=IERR) + if (ierr /= 0) then + print *, 'Error when opening ',util_csl_file + stop + end if +!GGR write (59) 'jj2lsj' + write (59,'(A6)') 'jj2lsj' +!GGR write (59) NELEC, NCF, NW, NBLOCK + write (59,'(4I12)') NELEC, NCF, NW, NBLOCK + DO JB = 1, NBLOCK + IATJPDUM = TWO_J(JB) +1 +!GGR write (59) JB, NCFINBLK(JB), NEVINBLK(JB), IATJPDUM + write (59,'(4I12)') JB, NCFINBLK(JB), NEVINBLK(JB), IATJPDUM + END DO + ELSE IF(ioutT == 2) THEN + util_csl_file = NAME(1:K-1)//'.lsj'//'.T' +!GGR OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='OLD', & + OPEN(59,FILE=util_csl_file,FORM='formatted',STATUS='OLD', & + IOSTAT=IERR) + IF (IERR /= 0) THEN + print *, 'Error when opening ',util_csl_file + stop + END IF +!GGR READ (59, IOSTAT=IERR) G92MIX + READ (59, '(A6)', IOSTAT=IERR) G92MIX + IF (IERR/=0 .OR. G92MIX/='jj2lsj') THEN + WRITE (ISTDE, *) 'Not a jj2lsj Transformation File;' + close(59) + stop + ENDIF +!GGR READ (25) NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + read (59,'(4I12)') NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + if(NELECDUM /= NELEC .or. NCFTOTDUM /= NCF .or. NWDUM /= NW & + .or. NBLOCKDUM /= NBLOCK) then + print*, NELEC, NCF, NW, NBLOCK + print*, NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + print*, "Wrong transformation file *.lsj.T" + close(59) + stop + end if + DO JB = 1, NBLOCKDUM + IATJPDUM = TWO_J(JB) +1 +!GGR read (59) JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + read (59,'(4I12)') JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + if(JBDUM /= JB .or. NCFINBLKDUM /= NCFINBLK(JB) .or. & + NEVINBLKDUM /= NEVINBLK(JB) .or. & + IATJPDUM /= TWO_J(JB) +1) then + print*, JB,NCFINBLK(JB), NEVINBLK(JB), TWO_J(JB) +1 + print*, JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + print*, "Wrong transformation file *.lsj.T" + close(59) + stop + end if + END DO + ENDIF END SUBROUTINE inscreen ! !*********************************************************************** @@ -1451,6 +1561,7 @@ SUBROUTINE jj2lsj ! Written by G. Gaigalas, * ! NIST last update: Dec 2015 * ! Modified by G. Gaigalas, May 2021 * +! Modified by G. Gaigalas 2022 * ! * !*********************************************************************** !----------------------------------------------- @@ -1474,7 +1585,7 @@ SUBROUTINE jj2lsj ! L o c a l V a r i a b l e s !----------------------------------------------- !GG NIST - integer :: i, j, jj, ii, string_l, IBLKNUM,ioutC,ioutj,UNIQUE + integer :: i, j, jj, ii, string_l,IBLKNUM,ioutC,ioutj,UNIQUE,ioutT integer :: level, nocsf_min, lev, string_length integer :: nocsf_max, sum_nocsf_min, Before_J !GG NIST @@ -1497,7 +1608,8 @@ SUBROUTINE jj2lsj character(LEN=164), dimension(1:Vectors_number) :: string_CSF !----------------------------------------------- Ssms = ZERO; g_j = ZERO; g_JLS = ZERO; Before_J = 0 - call inscreen(THRESH,levels,number_of_levels,ioutC,ioutj,UNIQUE) + call inscreen(THRESH,levels,number_of_levels,ioutC,ioutj,UNIQUE, & + ioutT) allocate(ithresh(NCF)) do IBLKNUM = 1, NBLOCK if(IBLKNUM == 1) THEN @@ -1578,7 +1690,8 @@ SUBROUTINE jj2lsj ! perform the transformation ! if(lev == 1) call asf2ls & - (iw(1),ithresh,number_of_levels(IBLKNUM),IBLKNUM,levels,NCFMIN,NCFMAX) + (iw(1),ithresh,number_of_levels(IBLKNUM),IBLKNUM,levels, & + NCFMIN,NCFMAX,ioutT) ! ! output to the screen jj- coupling print *, "Weights of major contributors to ASF in jj-coupling:" From 1642d85e16745a06eeab8cf1c6200ead5498e3e4 Mon Sep 17 00:00:00 2001 From: Gediminas Gaigalas Date: Mon, 17 Apr 2023 15:24:47 +0200 Subject: [PATCH 3/5] small formatting fix --- src/appl/jj2lsj90/jj2lsj_code.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/appl/jj2lsj90/jj2lsj_code.f90 b/src/appl/jj2lsj90/jj2lsj_code.f90 index 26bd5040..11f5823d 100644 --- a/src/appl/jj2lsj90/jj2lsj_code.f90 +++ b/src/appl/jj2lsj90/jj2lsj_code.f90 @@ -2324,7 +2324,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) ! ! 4. for each nonequivalent csf_jj find all the csfs_LS ! -! To avoid the dependency on the number of subshells +! To avoid the dependency on the number of subshells ! the recursive subroutine is used allocate(Li(asf_set_LS%csf_set_LS%nwshells)) allocate(L_i(asf_set_LS%csf_set_LS%nwshells)) From 5db76d8256e16d94d44bd0dd8a1a303404fb789f Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Fri, 21 Apr 2023 07:51:31 +0200 Subject: [PATCH 4/5] binary output format of .T files --- src/appl/jj2lsj90/jj2lsj_code.f90 | 97 +++++++++++++++---------------- 1 file changed, 47 insertions(+), 50 deletions(-) diff --git a/src/appl/jj2lsj90/jj2lsj_code.f90 b/src/appl/jj2lsj90/jj2lsj_code.f90 index 11f5823d..e3bacbc0 100644 --- a/src/appl/jj2lsj90/jj2lsj_code.f90 +++ b/src/appl/jj2lsj90/jj2lsj_code.f90 @@ -218,35 +218,32 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN, & real(DOUBLE), dimension(Vectors_number) :: wb !----------------------------------------------- wb = zero -!GGR if(ioutT == 1) write(59) ' * Block Number=',IBLKNUM - if(ioutT == 1) write(59,'(A18,I6)') ' * Block Number=',IBLKNUM + if(ioutT == 1) write(59) ' * Block Number=',IBLKNUM if(ioutT == 2) then -!GGR read(59) String, IDUM - read(59,'(A18,I6)') String, IDUM + read(59) String, IDUM if(String(1:18) /= ' * Block Number=' .or. & IDUM /= IBLKNUM) then - print*, "Error in transformation file *.lsj.T" + print*, "Error in transformation file *.lsj.T" end if end if do LS_number = 1, asf_set_LS%csf_set_LS%nocsf - if ((asf_set_LS%csf_set_LS%csf(LS_number)%parity == "+" & - .and. ISPAR(iw1) == 1) .or. & - (asf_set_LS%csf_set_LS%csf(LS_number)%parity == "-" & + if(((LS_number/2000)*2000) == LS_number) & + print*, "LS_number=",LS_number + if ((asf_set_LS%csf_set_LS%csf(LS_number)%parity == "+" & + .and. ISPAR(iw1) == 1) .or. & + (asf_set_LS%csf_set_LS%csf(LS_number)%parity == "-" & .and. ISPAR(iw1) == -1)) then wa = zero do jj_number = NCFMIN, NCFMAX - if(ithresh(jj_number) == 1 .and. & - (asf_set_LS%csf_set_LS%csf(LS_number)%totalJ == & + if(ithresh(jj_number) == 1 .and. & + (asf_set_LS%csf_set_LS%csf(LS_number)%totalJ == & ITJPO(jj_number)-1)) then if(ioutT <= 1) & - wa_transformation = traLSjj(jj_number,LS_number) -!GGR if(ioutT == 1) write(59) wa_transformation - if(ioutT == 1) write(59,'(2I6,2X,F16.9)') & - jj_number-NCFMIN+1,LS_number,wa_transformation + wa_transformation = traLSjj(jj_number,LS_number) + if(ioutT == 1) write(59) & + jj_number-NCFMIN+1,LS_number,wa_transformation if(ioutT == 2) then -!GGR read(59) wa_transformation - read(59,'(2I6,2X,F16.9)') & - ijj, iLS, wa_transformation + read(59) ijj, iLS, wa_transformation if(ijj /= jj_number-NCFMIN+1 .or. & iLS /= LS_number ) then print*, "Error in jj2lsj transformation file" @@ -1126,7 +1123,7 @@ END SUBROUTINE gettermLS ! !*********************************************************************** ! * - SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & + SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & UNIQUE,ioutT) ! * ! The input from the screen. * @@ -1147,7 +1144,6 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & USE PRNT_C, ONLY: NVEC USE IOUNIT_C, ONLY: ISTDI, ISTDE USE CONS_C, ONLY: EPS, ZERO -!GG USE BLK_C, ONLY: NEVINBLK, NBLOCK USE BLK_C, ONLY: NEVINBLK, NCFINBLK, NBLOCK, TWO_J USE m_C, ONLY: NCORE USE def_C, ONLY: Z, NELEC @@ -1308,20 +1304,24 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ioutj = 0 END IF END IF - WRITE (ISTDE,*) & - "Do you need the transformation output file *.lsj.T? (y/n)" - YES = GETYN () - IF (YES) THEN - ioutT = 1 - ELSE - WRITE (ISTDE,*) & - "Will you use the transformation file *.lsj.T? (y/n)" + IF(MINCOMP == ZERO) THEN + WRITE (ISTDE,*) & + "Do you need the transformation output file *.lsj.T? (y/n)" YES = GETYN () IF (YES) THEN - ioutT = 2 + ioutT = 1 ELSE - ioutT = 0 + WRITE (ISTDE,*) & + "Will you use the transformation file *.lsj.T? (y/n)" + YES = GETYN () + IF (YES) THEN + ioutT = 2 + ELSE + ioutT = 0 + END IF END IF + ELSE + ioutT = 0 END IF ENDIF ! @@ -1388,40 +1388,33 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ! IF(ioutT == 1) THEN util_csl_file = NAME(1:K-1)//'.lsj'//'.T' -!GGR OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='NEW', & - OPEN(59,FILE=util_csl_file,FORM='formatted',STATUS='NEW', & + OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='NEW', & IOSTAT=IERR) if (ierr /= 0) then print *, 'Error when opening ',util_csl_file stop end if -!GGR write (59) 'jj2lsj' - write (59,'(A6)') 'jj2lsj' -!GGR write (59) NELEC, NCF, NW, NBLOCK - write (59,'(4I12)') NELEC, NCF, NW, NBLOCK + write (59) 'jj2lsj' + write (59) NELEC, NCF, NW, NBLOCK DO JB = 1, NBLOCK - IATJPDUM = TWO_J(JB) +1 -!GGR write (59) JB, NCFINBLK(JB), NEVINBLK(JB), IATJPDUM - write (59,'(4I12)') JB, NCFINBLK(JB), NEVINBLK(JB), IATJPDUM + IATJPDUM = TWO_J(JB) +1 + write (59) JB, NCFINBLK(JB), NEVINBLK(JB), IATJPDUM END DO ELSE IF(ioutT == 2) THEN util_csl_file = NAME(1:K-1)//'.lsj'//'.T' -!GGR OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='OLD', & - OPEN(59,FILE=util_csl_file,FORM='formatted',STATUS='OLD', & + OPEN(59,FILE=util_csl_file,FORM='unformatted',STATUS='OLD', & IOSTAT=IERR) IF (IERR /= 0) THEN print *, 'Error when opening ',util_csl_file stop END IF -!GGR READ (59, IOSTAT=IERR) G92MIX - READ (59, '(A6)', IOSTAT=IERR) G92MIX + READ (59, IOSTAT=IERR) G92MIX IF (IERR/=0 .OR. G92MIX/='jj2lsj') THEN WRITE (ISTDE, *) 'Not a jj2lsj Transformation File;' close(59) stop ENDIF -!GGR READ (25) NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM - read (59,'(4I12)') NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM + READ (59) NELECDUM, NCFTOTDUM, NWDUM, NBLOCKDUM if(NELECDUM /= NELEC .or. NCFTOTDUM /= NCF .or. NWDUM /= NW & .or. NBLOCKDUM /= NBLOCK) then print*, NELEC, NCF, NW, NBLOCK @@ -1432,8 +1425,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & end if DO JB = 1, NBLOCKDUM IATJPDUM = TWO_J(JB) +1 -!GGR read (59) JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM - read (59,'(4I12)') JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM + read (59) JBDUM, NCFINBLKDUM, NEVINBLKDUM, IATJPDUM if(JBDUM /= JB .or. NCFINBLKDUM /= NCFINBLK(JB) .or. & NEVINBLKDUM /= NEVINBLK(JB) .or. & IATJPDUM /= TWO_J(JB) +1) then @@ -1630,6 +1622,7 @@ SUBROUTINE jj2lsj end do if(dabs(sumthrsh) >= dabs(EPSNEW)) ithresh(i) = 1 end do + write(*,*)'The program generates a list of CSFs in LS-coupling' call setLS(ithresh,NCFMIN,NCFMAX) ! ! output to *.lsj.c @@ -1689,9 +1682,13 @@ SUBROUTINE jj2lsj ! ! perform the transformation ! - if(lev == 1) call asf2ls & - (iw(1),ithresh,number_of_levels(IBLKNUM),IBLKNUM,levels, & - NCFMIN,NCFMAX,ioutT) + if(lev == 1) then + write(*,*) & + 'The program generates a list of transformation matrix' + call asf2ls & + (iw(1),ithresh,number_of_levels(IBLKNUM),IBLKNUM,levels,& + NCFMIN,NCFMAX,ioutT) + end if ! ! output to the screen jj- coupling print *, "Weights of major contributors to ASF in jj-coupling:" @@ -2324,7 +2321,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) ! ! 4. for each nonequivalent csf_jj find all the csfs_LS ! -! To avoid the dependency on the number of subshells +! To avoid the dependency on the number of subshells ! the recursive subroutine is used allocate(Li(asf_set_LS%csf_set_LS%nwshells)) allocate(L_i(asf_set_LS%csf_set_LS%nwshells)) From b7b850a6fd9996d20dbabf9398872ddbbedaf016 Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Fri, 21 Apr 2023 07:55:52 +0200 Subject: [PATCH 5/5] installation fix --- src/tool/CMakeLists.txt | 4 ++++ src/tool/Makefile | 7 +++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/tool/CMakeLists.txt b/src/tool/CMakeLists.txt index 837c05ca..e38a2e6a 100644 --- a/src/tool/CMakeLists.txt +++ b/src/tool/CMakeLists.txt @@ -98,3 +98,7 @@ add_executable(fical fical.f90) target_link_libraries_Fortran(fical PRIVATE mod 9290) install(TARGETS fical DESTINATION bin/) +add_executable(rfinetune rfinetune.f90) +target_link_libraries_Fortran(rfinetune PRIVATE mod 9290) +install(TARGETS rfinetune DESTINATION bin/) + diff --git a/src/tool/Makefile b/src/tool/Makefile index a58dc01b..1c431a79 100644 --- a/src/tool/Makefile +++ b/src/tool/Makefile @@ -1,7 +1,7 @@ LIBS=-L ${GRASP}/lib/ -l9290 -lmod FC_MODULES=-I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -all: ${GRASP}/bin/rsave ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rwfnpyplot ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot ${GRASP}/bin/rwfntotxt ${GRASP}/bin/fical +all: ${GRASP}/bin/rsave ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rwfnpyplot ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot ${GRASP}/bin/rwfntotxt ${GRASP}/bin/fical ${GRASP}/bin/rfinetune ${GRASP}/bin/rsave: rsave cp $^ $@ @@ -87,9 +87,12 @@ ${GRASP}/bin/rwfntotxt: rwfntotxt.o ${GRASP}/bin/fical: fical.o $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) +${GRASP}/bin/rfinetune: rfinetune.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) + %.o: %.f90 $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f ${GRASP}/bin/rsave ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rwfnpyplot ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot ${GRASP}/bin/rwfntotxt ${GRASP}/bin/fical + -rm -f ${GRASP}/bin/rsave ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rwfnpyplot ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot ${GRASP}/bin/rwfntotxt ${GRASP}/bin/fical ${GRASP}/bin/rfinetune -rm -f *.o *.mod