! omgcmp.f 09/01/19 ! ! compare two omega files, preferably at the same energies... ! ! default operation requires no user input. ! program main ! implicit double precision (a-h,o-z) ! parameter (zero=0.0d0) ! LOGICAL BFORM ! character elas*3 ! ALLOCATABLE :: ENAT1(:),LAT1(:),ISAT1(:),OMEG1(:),NRD1(:),it(:) ALLOCATABLE :: ENAT2(:),LAT2(:),ISAT2(:),OMEG2(:),NRD2(:),jt(:) ! NAMELIST/SPARE/nomcmp,tole,tolo,rato,elas ! call cpu_time(timei) ! open(6,file='routcmp',status='unknown') ! rato=1.3 !log if ratio exceeeds tolo=1.d-3 !but only if omg larger than nomcmp=9999999 !restrict range of transitions comapred tole=-9999 !allow for slight mis-match of energy compared elas=' ' !defaults to YES/NO for neutral/ion elastic present ! INQUIRE (FILE='domgcmp',EXIST=BFORM) IF(BFORM)THEN OPEN(4,FILE='domgcmp',STATUS='OLD') READ(4,SPARE,END=10) ENDIF ! WRITE(6,100)nomcmp,rato,tolo,tole tole0=tole ! 10 INQUIRE (FILE='omgcmp1',EXIST=BFORM) IF(BFORM)THEN !USE FORMATTED OMEGA WRITE(6,*)'USING FORMATTED OMEGA FILES' WRITE(0,*)'USING FORMATTED OMEGA FILES' open(1,file='omgcmp1',status='old') !file1 open(2,file='omgcmp2',status='old') !file2 OPEN(9,STATUS='SCRATCH',FORM='FORMATTED') ELSE WRITE(6,*)'USING UNFORMATTED OMEGA FILES' WRITE(0,*)'USING UNFORMATTED OMEGA FILES' open(1,file='omgcmp1u',status='old',FORM='UNFORMATTED') !file1 open(2,file='omgcmp2u',status='old',FORM='UNFORMATTED') !file2 ENDIF ! open(3,file='omgcmpt',status='unknown') !log diffs ! IF(BFORM)THEN read(1,*) nzed1,nelc1 read(2,*) nzed2,nelc2 read(1,*) nast1,mxe1,nomt1 read(2,*) nast2,mxe2,nomt2 ELSE read(1) nzed1,nelc1 read(2) nzed2,nelc2 read(1) nast1,mxe1,nomt1 read(2) nast2,mxe2,nomt2 ENDIF ! write(3,*) nzed2,nelc2 ! mxe1=iabs(mxe1) mxe2=iabs(mxe2) if(mxe1.gt.mxe2)then if(mxe1.ne.mxe2+1)stop'mis-match of omega files on mxe1 & mxe2' elseif(mxe1.lt.mxe2)then if(mxe1.ne.mxe2-1)stop'mis-match of omega files on mxe1 & mxe2' endif ! if(nzed1.ne.nzed2.or.nelc1.ne.nelc2) then write(6,*)' mis-match of omega files on nzed and nelc' write(6,*) 'nzed1 = ',nzed1,' nzed2 = ',nzed2 write(6,*) 'nelc1 = ',nelc1,' nelc2 = ',nelc2 stop 'mis-match of omega files on nzed or nelc' endif ! if(nast1.ne.nast2.or.nomt1.ne.nomt2) then write(6,*) 'mis-match of omega files on nast or nomt' write(6,*) 'nast1 = ',nast1,' nast2 = ',nast2 write(6,*) 'nomt1 = ',nomt1,' nomt2 = ',nomt2 stop 'mis-match of omega files on nast or nomt' endif ! IF(ELAS.EQ.' ')THEN IF(NZED1.EQ.NELC1)ELAS='YES' IF(NZED1.NE.NELC1)ELAS='NO' ENDIF IF(ELAS.EQ.'YES')THEN IONE=0 ELSEIF(ELAS.EQ.'NO')THEN IONE=1 ELSE WRITE(6,*)' UNRECOGNIZED OPTION ELAS=',ELAS STOP ' UNRECOGNIZED ELAS OPTION' ENDIF ! NOMWRT=NOMT1 !NOMT1=NOMT2 NOMT1=ABS(NOMT1) NOMT2=ABS(NOMT2) IF(NOMT1*NOMT2.EQ.0)STOP 'NEED NOMWRT TO BE SPECIFIED' ! ALLOCATE (ENAT1(NAST1),LAT1(NAST1),ISAT1(NAST1),OMEG1(NOMT1) & & ,NRD1(MXE1),it(nomt1),STAT=IERR) IF(IERR.NE.0)THEN WRITE(0,*)'ALLOCATION FAILS FOR NAST,NOMT,MXE=',NAST1,NOMT1,MXE1 STOP 'ABORT 1' ENDIF ALLOCATE (ENAT2(NAST2),LAT2(NAST2),ISAT2(NAST2),OMEG2(NOMT2) & & ,NRD2(MXE2),jt(nomt2),STAT=IERR) IF(IERR.NE.0)THEN WRITE(0,*)'ALLOCATION FAILS FOR NAST,NOMT,MXE=',NAST2,NOMT2,MXE2 STOP 'ABORT 2' ENDIF ! IF(BFORM)THEN !ASSUME IDENTICAL, DON'T TEST... read(1,*) (ISAT1(I),LAT1(I),i=1,nast1) read(1,*) (enat1(i),i=1,nast1) ! read(2,*) (ISAT2(I),LAT2(I),i=1,nast2) read(2,*) (enat2(i),i=1,nast2) ELSE read(1) (ISAT1(I),LAT1(I),i=1,nast1) read(1) (enat1(i),i=1,nast1) ! read(2) (ISAT2(I),LAT2(I),i=1,nast2) read(2) (enat2(i),i=1,nast2) ENDIF ! nz=max(nzed1-nelc1,1) nz=nz*nz do i=1,nast1 write(3,90) i,ISAT1(I),LAT1(I),enat1(i),enat1(i)*nz ! write(3,90) i,ISAT2(I),LAT2(I),enat2(i),enat2(i)*nz enddo ! IF(NOMWRT.GE.0)THEN !AND CASE MXE0.LT.0 ! N=0 DO I=1,NAST1 DO J=I+IONE,NAST1 N=N+1 IT(N)=I JT(N)=J ENDDO ENDDO ! DO I=1,MXE1 NRD1(I)=NOMT1 ENDDO DO I=1,MXE2 NRD2(I)=NOMT2 ENDDO ! ELSE ! N=0 DO J=1+IONE,NAST1 DO I=1,J-IONE N=N+1 IT(N)=I JT(N)=J ENDDO ENDDO ! IF(BFORM)READ(1,*)E01 !CHECK FIRST E IF(.NOT.BFORM)READ(1)E01 !CHECK FIRST E BACKSPACE(1) I=1 IF(E01.GE.ENAT1(NAST1))GO TO 1 !ALL OPEN - EARLY EXIT IF(BFORM)THEN I0=1 NO=NOPEN(E01,ENAT1,NAST1,IONE,I0) NO=MIN(NO,NOMT1) READ(1,*)E01,(DUM,N=1,NO) READ(1,*)E !=E0+EINCR EINCR1=E-E01 E01=E01-EINCR1 EINCH1=EINCR1*0.5 NREC=2+(NO-1)/6 DO N=1,NREC BACKSPACE(1) ENDDO ENDIF I0=1 DO I=1,MXE1 IF(BFORM)THEN E=E01+I*EINCR1 WRITE(9,110)E BACKSPACE(9) READ(9,110)E BACKSPACE(9) ELSE READ(1)E ENDIF IF(E.GE.ENAT1(NAST1))GO TO 1 NRD1(I)=NOPEN(E,ENAT1,NAST1,IONE,I0) NRD1(I)=MIN(NRD1(I),NOMT1) ENDDO I=MXE1+1 1 I0=I DO I=I0,MXE1 NRD1(I)=NOMT1 ENDDO IF(.NOT.BFORM)THEN REWIND(1) NREC=4 DO N=1,NREC READ(1) ENDDO ENDIF ! IF(BFORM)READ(2,*)E02 !CHECK FIRST E IF(.NOT.BFORM)READ(2)E02 !CHECK FIRST E BACKSPACE(2) I=1 IF(E02.GE.ENAT2(NAST2))GO TO 2 !ALL OPEN - EARLY EXIT IF(BFORM)THEN I0=1 NO=NOPEN(E02,ENAT2,NAST2,IONE,I0) NO=MIN(NO,NOMT2) READ(2,*)E02,(DUM,N=1,NO) READ(2,*)E !=E0+EINCR EINCR2=E-E02 E02=E02-EINCR2 EINCH2=EINCR2*0.5 NREC=2+(NO-1)/6 DO N=1,NREC BACKSPACE(2) ENDDO ENDIF I0=1 DO I=1,MXE2 E=E02+I*EINCR2 IF(BFORM)THEN WRITE(9,110)E BACKSPACE(9) READ(9,110)E BACKSPACE(9) ELSE READ(2)E ENDIF IF(E.GE.ENAT2(NAST2))GO TO 2 NRD2(I)=NOPEN(E,ENAT2,NAST2,IONE,I0) NRD2(I)=MIN(NRD2(I),NOMT2) ENDDO I=MXE2+1 2 I0=I DO I=I0,MXE2 NRD2(I)=NOMT2 ENDDO IF(.NOT.BFORM)THEN REWIND(2) NREC=4 DO N=1,NREC READ(2) ENDDO ENDIF ! ENDIF ! ! read energies and omegas from file1 and file2, and compare one ! energy at a time - log diffs to file3. ! emesh=-9999 mxe=min(mxe1,mxe2) ! do i=1,mxe ! IF(BFORM)THEN ! read(1,*) emesh1,(omeg1(n),n=1,NRD1(I)) IF(NOMWRT.LT.0)THEN ET=E01+I*EINCR1 IF(ABS(EMESH1-ET).GT.EINCH1)THEN IF(NRD1(I).LT.NOMT1)THEN WRITE(6,*)'*** MIS-MATCH DURING READ OF FORMATTED OMEGAS' WRITE(6,*)I,NRD1(I),ET,EMESH1 STOP'*** MIS-MATCH DURING READ OF FORMATTED OMEGAS' ENDIF ENDIF ENDIF ! read(2,*) emesh2,(omeg2(n),n=1,NRD2(I)) IF(NOMWRT.LT.0)THEN ET=E02+I*EINCR2 IF(ABS(EMESH2-ET).GT.EINCH2)THEN IF(NRD2(I).LT.NOMT2)THEN WRITE(6,*)'*** MIS-MATCH DURING READ OF FORMATTED OMEGAS' WRITE(6,*)I,NRD2(I),ET,EMESH2 STOP'*** MIS-MATCH DURING READ OF FORMATTED OMEGAS' ENDIF ENDIF ENDIF ! ELSE ! read(1) emesh1,(omeg1(n),n=1,NRD1(I)) read(2) emesh2,(omeg2(n),n=1,NRD2(I)) ! ENDIF ! if(tole0.lt.zero)then dele=emesh1-emesh tole=dele/10 endif ! if(abs(emesh1-emesh2).lt.tole)then !close enough to compare if(nrd1(i).eq.nrd2(i))then nomt=min(nrd1(i),nomcmp) do n=1,nomt if(omeg1(n).gt.omeg2(n))then omax=omeg1(n) omin=omeg2(n) isign=1 else omax=omeg2(n) omin=omeg1(n) isign=-1 endif if(omin.eq.zero)then orat=1000*omax else orat=omax/omin if(orat.gt.rato.and.omin.gt.tolo)write(3,110) & & i,emesh1,n,it(n),jt(n),omeg1(n),omeg2(n),orat*isign endif enddo endif endif ! enddo ! DEALLOCATE (ENAT1,LAT1,ISAT1,OMEG1,NRD1,it,STAT=IERR) IF(IERR.NE.0)THEN WRITE(0,*)'DE-ALLOCATION FAILS FOR NAST1,NOMT1,MXE1...' STOP 'ABORT' ENDIF ! DEALLOCATE (ENAT2,LAT2,ISAT2,OMEG2,NRD2,jt,STAT=IERR) IF(IERR.NE.0)THEN WRITE(0,*)'DE-ALLOCATION FAILS FOR NAST2,NOMT2,MXE2...' STOP 'ABORT' ENDIF ! call cpu_time(timef) ! time=(timef-timei)/60. write(*,777)time 777 format(' CPU TIME=',f9.3,' MIN') ! STOP 'NORMAL FINISH TO COMPARING' ! 90 format(i6,2i4,1p,2e16.6) 100 FORMAT('NOMCMP=',I9,5X,'RATO=',F12.4,5X,'TOLO=',1PE11.3,5X & & ,'TOLE=',1PE11.3) 110 format(i9,5x,1pe14.8,3x,i8,2i7,3x,2e11.3,0p,f12.4) ! end ! !************************************************ ! INTEGER FUNCTION NOPEN(E,ENAT,NAST,IONE,I0) IMPLICIT REAL*8 (A-H,O-Z) ! DIMENSION ENAT(NAST) ! DO I=I0,NAST IF(E.LT.ENAT(I))GO TO 1 ENDDO I=NAST+1 1 I0=I-1 NOPEN=(I0*(I0-2*IONE+1))/2 ! RETURN END