PROGRAM TRAVEC *************************** File: U625002 TRAVEC FORTRAN N = TRAVEC FOR **** Last update: 11 Nov. 1999 **** G. Admiraal: ''a new version of TRAVEC (author G. Schaefer), ... '' **** Last part of file: see ORIENT: Nordman, Strumpel, G.Beurskens, ptb. **** Juny 1996: optimizations via rotations disabled !!!!!!!!!!!!!!!!!!! **** OLD VERSION AVAILABLE ON REQUEST ==> file U625002 TRAVECR FORTRAN E ************************************************************************ * wensen: - test op MAXVEC=960? - div subr oppoetsen COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IATOMS, IFILE(1)) EQUIVALENCE (IKLAD, IFILE(20)) EQUIVALENCE (IATOLD, IFILE(2)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IFMAP, IFILE(17)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 PARAMETER (MAXAT = 213) COMMON /CARATP/ NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3) COMMON /TRAVDA/ MM CHARACTER*6 LAT(1) DIMENSION CARXIN(3,MAXAT), XYZTIN(3), INHVAM(50) DATA LAT /'ATOMS'/ CALL KEPROG( 'TRAVEC' ) WRITE (LIS2, FMT = '('' Last TRAVEC update: 11 Nov. 1999'')') CALL PRETRA CALL PRETAB CALL CONTRA KSTOP = 0 CALL TRADEK (KSTOP) IF (KSTOP .NE. 0) GOTO 1111 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) CALL KERROR ('Error on file ATOMS', -1,'TRAVEC') CALL FILINQ (IKLAD, 'ATOMK', 'FORMATTED', 'SCRATCH', KINQ) MMODH=50 MMMOD=0 111 CALL KERIFF (IATOMS, LAT, 1, LEND) IF (LEND.EQ.-1 .OR. LEND.GT.0) GOTO 1000 IF (NLUSER(1).LE.0) GOTO 111 IFOM = 100 IBOTS = 0 R2X = 1.00 IF (LIT(NLIT) .NE. 'FOM=' .AND. LIT(NLIT-1) .NE. 'FOM=') THEN WRITE (LIS1,FMT='('' Old TRACOR output: FOM= not avalable'')') ELSEIF (LIT(NLIT) .EQ. 'FOM=') THEN IFOM = NINT(FNUM(NFNUM)) IF(LIT(NLIT-1) .EQ. 'R2=') R2X = FNUM(NFNUM-1) ELSE IFOM = NINT(FNUM(NFNUM-1)) IF (LIT(NLIT) .EQ. 'X=') IBOTS = NINT(FNUM(NFNUM)) IF(LIT(NLIT-2) .EQ. 'R2=') R2X = FNUM(NFNUM-2) ENDIF IFOMX(1,MMMOD+1) = IFOM IFOMX(2,MMMOD+1) = IBOTS IFOMX(3,MMMOD+1) = NINT (R2X * 1000.) BACKSPACE IATOMS CALL MODSIN (IATOMS, NAT, CARXIN, XYZTIN, IZATOM) IF (NAT .LE. 1 .OR. NAT .GT. MAXAT) GOTO 1111 GRIDS1 = DISPMX/2. MM = MMMOD+1 CALL REFMOD (MM, CARXIN, XYZTIN) IF (MM .LT. 0) GOTO 1111 MMMOD=MMMOD+1 WRITE (LIS1, FMT='(/'' TEMP: Number of models:'', I3)') MMMOD IF (MMMOD .LT. MMODH) GOTO 111 1000 IF (MMMOD .LE. 1) THEN WRITE (LIS1, FMT='(/'' One model only.......... STOP....''/ * '' Bypass further TRAVEC calculations. ''/)') GOTO 1111 ENDIF CALL SQMODL (MMMOD, INHVAM, MMODH) GOTO 9999 1111 CONTINUE CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') WRITE (LIS1, 710) WRITE (LIS2, 710) 710 FORMAT (/ * ' All TRACOR results sets are written to the ATOLD file.' /) IF (IFOMX(2,1) .LE. 0) GOTO 9999 WRITE (IPR1, 810) WRITE (LIS1, 810) WRITE (LIS2, 810) 810 FORMAT (/ * ' NOTE. The first ATOMS set from TRACOR is not acceptable, as ' / * ' the molecule collides with symmetry related molecules !!!!' / * ' You may decide what is best to do next ... We will STOP' / * ' If the molecule is on a symmetry element, then use your' / * ' local software to generate a symmetry independent fragment' / * ' to be stored in the ATOMS file, and then continue with' / * ' DIRDIF CCODE PHASEX for completion of the structure. !!!!!' ) CALL FILINQ (IDDSY, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IDDSY, FMT='(''STOP'')') CALL FILCLO (IDDSY, 'KEEP') 9999 CALL FILCLO (IATOMS, 'KEEP') IDDOKA = KEYS(10) IF (IDDOKA .EQ. 17) GOTO 999 CALL KEPROX 999 CONTINUE WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 99 END SUBROUTINE PRETRA COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (ICRYS, IFILE(3)), (LIS1, IFILE(7)) EQUIVALENCE (ICOND, IFILE(4)) EQUIVALENCE (KLAUE, KEYS(6)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON /IMSEFU/ MSUM, AMINMN, AMINMX CHARACTER*6 LITA(1) DATA LITA(1) / 'TRAVEC' / 91 CALL RDCOND (ICOND, LITA, 1, KEND) IF (KEND .LE. 0) GOTO 92 GOTO 91 92 CONTINUE CALL FILCLO (ICOND, 'KEEP') WRITE (LIS1, FMT='('' Execute TRAVEC without optimization'')') CALL RDCRYS( ICRYS ) CALL FILCLO( ICRYS, 'KEEP' ) GOTO * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE 101 KLAUE = 1 GOTO 105 102 IF (IUNIQ .EQ. 3) GOTO 104 KLAUE = 2 GOTO 105 103 KLAUE = 3 GOTO 105 104 KLAUE = 4 105 CONTINUE MSUM = 200 RETURN END SUBROUTINE PRETAB COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IDDL, IFILE(9)) EQUIVALENCE (SINGPK, KEYS(27)) EQUIVALENCE (ORIGIN, KEYS(28)) COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) DIMENSION PATP(8) DATA DELY,DEL2Y /0.,0./ DEL = .01 CALL LOGRD (IDDL, 'SINGPK', KLOG) IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PRETRA') IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR * ('DDLOG file not correct, SINGPK a/o ORIGIN missing',-1,'PRETRA') SINGPK = FNUM(2) ORIGIN = FNUM(3) CALL LOGRD (IDDL, 'PK', KLOG) CALL FILCLO (IDDL, 'KEEP') IF (KLOG.LE.0 .OR. NFNUM.NE.9) CALL KERROR * ('DDLOG file: no peak shape (Rerun Patterson)',-1,'PRETRA') CALL KERNAB (FNUM(2), PATP, 8) IF (PATP(1) .LT. .5) * CALL KERROR ('wrong PK SHAPE in DDLOG file', 0, 'VEC') DO 120 I = 2, 8 IF (PATP(I) .LT. 0.) PATP(I) = 0. IF (PATP(I-1) .LT. 0.2) THEN PATP(I-1) = PATP(I-1) * 0.9 PATP(I) = AMIN1 (0.99, PATP(I)) ENDIF PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I))) 120 CONTINUE WRITE (LIS2, 123) PATP 123 FORMAT (' PEAK PROFILE: ', * 'for x.a = 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8'/ * 16X, 'shape = 1.000', 8F6.3 ) TAB(1) = 1. IMAX2=0 IXL = 0 I = 2 36 RRR = SQRT(FLOAT(I) - 0.9999) IX = RRR IF (IX .LE. 0) THEN WRITE (LIS1, FMT='('' Important error = IX = tell PTB'')') IX = 1 ENDIF IF (IX.EQ.IXL) GOTO 37 IXL = IX TAB(I) = PATP(IX) IF (IX.EQ.7) GOTO 38 DELY = PATP(IX+1) - PATP(IX) DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY ) GOTO 38 37 DELX = RRR - FLOAT(IX) TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y 38 IF (TAB(I).GT.0.1) IMAX2 = I - 1 I = I + 1 IF (I.LE.50) GOTO 36 IF (IMAX2.GT.48) IMAX2=48 RMAX2 = FLOAT(IMAX2) / 100. RMAX = SQRT( RMAX2) RETURN END SUBROUTINE CONTRA COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (SCADEK, KEYS(26)) EQUIVALENCE (LIS2, IFILE(8)) COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) WRITE (LIS2, FMT=' * ('' TRAVEC calculates AMINM for all input models,''/ * '' AMINM = maximum of image seeking function (ISF) ''/ * /'' Values and effects of control variables:''/)') SCADEK=0.2 DISPMX = 0.32 IF ( DISPMX .GT. RMAX ) DISPMX = RMAX DISPMX = DISPMX/2. VMIN = 0.7 VMAX = 10. WRITE (LIS2, FMT='('' Intra-model vectors with length > than'', * '' VMAX ='',F5.1, /'' do not contribute to ISF.'', * '' Minimum length is VMIN ='',F5.1 )') VMAX, VMIN FRACM = 0.30 WRITE (LIS2, FMT='('' Fraction of search-vectors which contributes * to minM is'',F5.2)') FRACM RETURN END SUBROUTINE TRADEK (KSTOP) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)),(IFMAP, IFILE(17)) EQUIVALENCE (KLAUE, KEYS(6)) EQUIVALENCE (SCADEK, KEYS(26)) EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28)) LOGICAL SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (NUMTAB = 200000) COMMON / / TTT, ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), TTT) COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3)) EQUIVALENCE (NUMX, NUM(1)) INTEGER * 2 LPAT(198) DIMENSION NXYZM(3) EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3)) DIMENSION ITLE(20) EQUIVALENCE (FFTSC, ITLE(18)) DATA JXYZC, LXYZC / 0, 0 / DATA IZ, KXYZC, IXYZC / 0, 0, 0 / ILMAX = 100000 DO 111 I = 1, NUMTAB 111 ITAB (I) = 0 MAXFUN = 30254 MIFUN = 0 FUNSUM = 0. CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ) IF (KINQ.NE.0) THEN WRITE(LIS1, FMT='( * '' Patterson file (FMAP, output ORIENT) not found:''/ * '' TRAVEC is bypassed.'')') KSTOP = 1 RETURN ENDIF READ (IFMAP) ITLE, IMAP, IHALF IF (SWPRI) WRITE (LIS2, FMT='('' IMAP, IHALF, FFTSC ='', * 2I3, F10.5)') IMAP, IHALF, FFTSC IF (IMAP .NE. 2 .AND. IMAP .NE. 6) THEN WRITE(LIS1, FMT='( * '' Patterson file (FMAP, output ORIENT) incorrect:''/ * '' No Patteron function (i.e. error on file FMAP):''/ * '' TRAVEC is bypassed.'')') KSTOP = 1 CALL FILCLO (IFMAP, 'DELETE') RETURN ENDIF READ (IFMAP) NX, NZ, NYHALF, NY WRITE (LIS2,6) NX, NY, NZ 6 FORMAT (' Patterson grid X * Y * Z = ' , I3, 2(' *',I3) ) SCAL = SCADEK ABSCAL = SCAL * FFTSC * VOLUM SINGPK = ORIGIN * ABSCAL * 18. /VOLUM IF (SWPRI) WRITE (LIS2, 138) FFTSC 138 FORMAT (' Input Patterson scale = ',12X, F10.5,' * volume ') IF (SWITCH(1)) WRITE (LIS2,1138) FFTSC 1138 FORMAT (' PTB TEMP Input SCALE: SCALOR = 3000 / sumF2 =' , F10.5) WRITE (LIS2, 152) SCAL, ABSCAL, SINGPK 152 FORMAT (' Input function values will be multiplied by: ', F10.5 / * ' To put the Patterson function on abs.scale * ', F9.5 / * ' Single-vector peak-height is approximately ' ,F10.2 /) K = 0 DO 12 I=1,3 L = (NXYZ(I)+1) / 2 IF (I.NE.2 .AND. KLAUE.LT.0) L=NXYZ(I)-1 IF (L.GT.ILMAX) CALL KERROR ('KANNIET', 12, 'TRADEK') LXYZ(I) = MIN0 (L, ILMAX) 12 IS(I) = 0 IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2) IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3) DO 14 I=1,3 NXYZM(I) = NXYZ(I) IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1 14 NUM(I) = LXYZ(I) - IS(I) + 1 NUMXY = NUM(1) * NUM(2) NUMXYZ = NUMXY * NUM(3) IF (NUMXYZ .GT. NUMTAB) THEN WRITE(LIS1, FMT='( * '' Storage problems in TRADEK: Patterson map is too large :''/ * '' TRAVEC is bypassed.'')') KSTOP = 1 RETURN ENDIF DO 217 I = 1,3 217 GTXYZ(I) = NXYZ(I) NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1 IF (NYM .GT. NYHALF) CHOUT = ' Please tell PTB: NYM gt NYHALF ' IF (NYM .GT. NYHALF) CALL SHOUT IF (NYM .GT. NYHALF) NYM=NYHALF DO 50 I1=1,NYM IY = I1 - 1 KY = IY - NY IXY = NUM(1) * IY KXY = NUM(1) * KY K = 1 IF (IS(2).EQ.0) GOTO 26 IF (IY .GT. LXYZ(2)) K=3 IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2 IF (K.EQ.2 .AND. IY.GT.ILMAX) K=3 IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1 IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0 IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0 IF (K.EQ.3) IXY=KXY 26 DO 48 I2=1,NZ IF (I2.GT.NZM) K=0 IF (K.EQ.0) GOTO 28 IZ = I2 - 1 IXYZ = NUMXY * IZ IXYZC = IXYZ + IXY - NUMC KXYZC = IXYZ + KXY - NUMC L = 1 IF (IS(3).EQ.0) GOTO 28 KZ = IZ - NZ JXYZ = NUMXY * KZ JXYZC = JXYZ + IXY - NUMC LXYZC = JXYZ + KXY - NUMC IF (IZ.GT.LXYZ(3)) L=3 IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2 IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3 IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1 IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0 IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0 IF (L.EQ.3) IXYZC=JXYZC IF (L.EQ.3) KXYZC=LXYZC 28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX) IF (K.EQ.0 .OR. L.EQ.0) GOTO 48 DO 40 I3=1,NXM FUN = LPAT(I3) FUN = 99. * (FUN * SCAL + 25.) IFUN = NINT(FUN) IF (IFUN) 32, 32, 30 30 IF (IFUN.GT.MIFUN) MIFUN=IFUN IF (IFUN .LE. MAXFUN) GOTO 36 IFUN = MAXFUN GOTO 36 32 IFUN = 0 36 LPAT(I3) = IFUN FUNSUM = FUNSUM + FLOAT(IFUN) IX = I3 - 1 IADR = IXYZC + IX IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=1=',-4,'TRADEK') ITAB(IADR) = IFUN IF (L.NE.2) GOTO 39 IADR = JXYZC + IX IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=2=',-4,'TRADEK') ITAB(IADR) = IFUN 39 IF (K.NE.2) GOTO 40 IADR = KXYZC + IX IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=3=',-4,'TRADEK') ITAB(IADR) = IFUN IF (L.NE.2) GOTO 40 IADR = LXYZC + IX IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=4=',-4,'TRADEK') ITAB(IADR) = IFUN 40 CONTINUE 48 CONTINUE 50 CONTINUE CALL FILCLO (IFMAP, 'DELETE') FUNSUM = FUNSUM / FLOAT(NUMXYZ) IFUN = FUNSUM WRITE (LIS2,52) MIFUN, IFUN 52 FORMAT (' Largest scaled Patterson value is: ', 15X, I5, / * 20X, ' averaged value is: ', 11X, I5, /) RETURN END SUBROUTINE MODSIN (IATOMS, NAT, CARXIN, XYZTIN, IZATOM) PARAMETER (MAXAT = 213) DIMENSION CARXIN(3,MAXAT),XYZTIN(3),IZATOM(MAXAT) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IATOLD, IFILE(2)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXATT = 993) COMMON /ATODAT/ NAT1, ATXYZ(10,MAXATT), IZAT(MAXATT), XYZT(3) COMMON /ATNAMA/ ATNAME(MAXATT) CHARACTER * 6 ATNAME DATA NATINP / 0/ IF (NATINP .EQ. 0) THEN WRITE (LIS2, FMT='('' Input parameter sets from file ATOMS'', * '' (TR= TRACOR output model number).'', * /'' Of each set, only the first atom is printed'', * '' for inspection.'' * / '' Atom name'', 5X, ''x'', 9X, ''y'', 9X, ''z''/)') NATINP = -1 ENDIF CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXATT, NAT, KEYT) WRITE (LIS2, FMT='(1X, A80)') CHIN NAT1 = NAT IF (NAT.LE.0) CALL KERROR('No atoms on ATOMS file',-1,'ATREAD') IF (NAT .LE. 1 .OR. NAT .GT. MAXAT) THEN IF (NAT .LE. 1) WRITE(LIS1, FMT='(/ * '' The input ATOMS file contains only one atom:'')') IF (NAT .GT. MAXAT) WRITE(LIS1, FMT='( //'' Hold it .......''/ * '' The input ATOMS file contains too many atoms:''/ * '' ( max: '', I4, '') : '')') MAXAT WRITE(LIS1, FMT='('' TRAVEC is bypassed./'')') RETURN ENDIF WRITE (LIS2, 112) ATNAME(1), (ATXYZ(J,1),J=1,3), IZAT(1) 112 FORMAT (3X, A6, 2X, 3F10.5, ' Z =', I3) CALL KERNZA (0., XYZT, 3) DO 10 I = 1, NAT 10 CALL VPLUSV (XYZT, ATXYZ(1,I), XYZT, 3) DO 11 J = 1, 3 11 XYZT(J) = - XYZT(J) / FLOAT(NAT) DO 20 I = 1, NAT CALL VPLUSV (ATXYZ(1,I), XYZT, ATXYZ(1,I), 3) 20 CONTINUE DO 300 I = 1,NAT CALL MAT6XV (FRAC2C, ATXYZ(1,I), ATXYZ(1,I)) 300 CONTINUE DO 110 N = 1,NAT CALL KERNAB (ATXYZ(1,N), CARXIN(1,N), 3 ) IZATOM(N) = IZAT(N) 110 CONTINUE CALL KERNAB(XYZT, XYZTIN, 3) RETURN END SUBROUTINE REFMOD (NOMODL, CARXIN, XYZTN) DIMENSION CARXIN(3,NAT), XYZTN(3) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IKLAD, IFILE(20)) EQUIVALENCE (IPR1,IFILE(6)), (LIS1,IFILE(7)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 PARAMETER (MAXAT = 213) COMMON /CARATP/ NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3) PARAMETER (MAXATT = 993) COMMON /ATNAMA/ ATNAME(MAXATT) CHARACTER * 6 ATNAME PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48) COMMON /IMSEFU/ MSUM, AMINMN, AMINMX DIMENSION ROFXYZ(3,MAXAT), SMINML(48), VALISF(5), VAMI(5), FRMM(5) LOGICAL LALLOW(MAXASV) LOGICAL ASYMNW CHARACTER*8 REMARK(10) CHARACTER*80 RMRK80 EQUIVALENCE (REMARK(1),RMRK80) DATA FRMM, VAMI / 0.1, 0.2, 0.3, 0.5, 0.7, 5*0./ DATA DMAX, DAVG /0.0, 0.0/ DO 100 I = 1, 3 XYZT(I) = XYZTN(I) DO 100 N = 1, NAT CARXYZ(I,N) = CARXIN(I,N) 100 CONTINUE DO 120 N = 1, NAT CALL MAT6XV (CART2F, CARXYZ(1,N), ROFXYZ(1,N)) CALL VMINV (ROFXYZ(1,N), XYZT, ROFXYZ(1,N), 3) 120 CONTINUE CALL VECLCO (LALLOW, VMAX, LIS1) IF (VMAX .LT. 0.0) THEN NOMODL = -1 RETURN ENDIF NTRPA = 1 DEMPT = 0.6666667 GRIDSZ = GRIDS1 / DEMPT DO 133 I = 1,3 GRISTP(I) = GRIDSZ / CELL(I) 133 CONTINUE CALL SCADIR CALL VECCAL (ROFXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW) CALL VECSET (ASYMNW) CALL CALISF (ROFXYZ, NAT, MSUM, SMINML, VALISF) AMINMX = VALISF( 3) DO 1010 I=1,5 MALL=NINT(FRMM(I)*NVV) IF (MALL.GT.200) MALL = 200 CALL ISF(MALL,VECT,NVV,VAM) 1010 VAMI(I)=VAM MALL=MSUM*NSMAX IF (MALL.GT.200) MALL=200 IFOM = IFOMX(1,NOMODL) VAMI(1) = AMINMX VAMI(5) = FLOAT(IFOM) / 1000. AMINMX = VAMI(1) * VAMI(5) * 10. WRITE (RMRK80, FMT= '(''REMARK '',I3,3F6.3,2I4,I3,5F6.3)') * NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5) CALL ATMOUT (IKLAD, CCODE, REMARK, ATNAME, NAT, ROFXYZ, NAT) WRITE (IPR1, FMT='( * '' TRAVEC on atom set TR='',I3, '' completed'')') NOMODL RETURN END SUBROUTINE VECLCO (LALLOW, VMAX, LIS1) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXAT = 213) COMMON /CARATP/ NAT, CARXYZ(3,MAXAT), IZATOM(MAXAT), XYZT(3) PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) EQUIVALENCE ( VECLEN(1,1), ASVECT(1,1) ) DIMENSION VECLEN(2,MAXASV) LOGICAL LALLOW(MAXASV) NSMXX = NSYMM IF (ICENT .NE. 1) NSMXX = 2 * NSMXX NVALLM = MAXASV/NSMXX - NAT 101 VMAXRE = 1./VMAX ACVMAX = 0. N = 0 NVALL = 0 NATM1 = NAT -1 DO 120 J = 1, NATM1 J1 = J + 1 DO 110 K = J1, NAT N = N + 1 IF (N .GT. MAXASV) THEN WRITE(LIS1, FMT='( * '' Dimension of LALLOW in VECLCO is too small!''/ * '' TRAVEC is bypassed.'')') VMAX = - 99. RETURN ENDIF NALLOW = ISELFC ( CARXYZ(1,J), CARXYZ(1,K), VMAX, DSTNCE ) IF (DSTNCE .LT. 0.7) THEN LALLOW(N) = .FALSE. VECLEN(1,N) = 0.1 VECLEN(2,N) = 10. GOTO 110 ENDIF IF ( NALLOW .EQ. 1 ) THEN NVALL = NVALL + 1 LALLOW(N) = .TRUE. VECLEN(1,N) = DSTNCE VECLEN(2,N) = 1./DSTNCE IF (DSTNCE .GT. ACVMAX) ACVMAX = DSTNCE ELSE LALLOW(N) = .FALSE. VECLEN(1,N) = VMAX VECLEN(2,N) = VMAXRE ENDIF 110 CONTINUE 120 CONTINUE IF (NVALL .GT. NVALLM) THEN NHIG1 = NVALLM+1 CALL DETSEQ(INDXHV, NHIG1, VECLEN,2,N, 2, 0) VMAX = VECLEN(1,INDXHV(NHIG1)) - .0001 IF (VMAX .LT. 9.0) WRITE (8, 346) NVALL, VMAX 346 FORMAT (' TEMP: VMAX reset: NVALL=',I5,' new VMAX=', F6.2) GOTO 101 ENDIF RETURN END SUBROUTINE DETSEQ ( INDXHV,NHIGST, ARRAY,NDIM1,NE, ISQ, N1) DIMENSION INDXHV(NHIGST), ARRAY(NDIM1,NE) IF (N1 .LT. NHIGST) THEN NRE = N1 ELSE NRE = NHIGST ENDIF NRE1 = NRE - 1 N2 = N1 + 1 DO 300 N = N2, NE IF ( N .GT. NHIGST ) THEN IF ( ARRAY( ISQ, N) .LE. ARRAY( ISQ, INDXHV(NRE)) ) GOTO 300 ENDIF IF (N .LE. NHIGST) THEN NRE1 = NRE NRE = N ENDIF IF (N .LE. 0) CALL KERROR (' CALL SRSEQN N', 300, 'DETSEQ') IF (NRE1 .LE. 0) THEN NR = 1 ELSE CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ,NR) ENDIF DO 100 I = NRE1, NR, -1 100 INDXHV(I+1) = INDXHV(I) INDXHV(NR) = N 300 CONTINUE RETURN END SUBROUTINE SRSEQN (INDXHV,NRE, EL,ARR2,I1,NE, ISQ, N) DIMENSION INDXHV(NRE), EL(I1), ARR2(I1,NE) N = NRE + 1 NG = 0 110 IF (NG .EQ. N-1) RETURN NLG = NG + (N - NG)/2 IF (EL(ISQ) .GT. ARR2(ISQ,INDXHV(NLG)) ) THEN N = NLG ELSE NG = NLG ENDIF GOTO 110 END SUBROUTINE SCADIR COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48) DIMENSION ISM(3,3,48) EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) ) IF (ICENT.EQ.1) THEN IN2 = 1 ELSE IN2 = -1 ENDIF NS = 0 DO 130 IN = 1,IN2,-2 DO 120 NSA= 1,NSYMM NS = NS + 1 DO 110 I = 1,3 DO 110 J = 1,3 ISM(I,J,NS) = IRSYMM(I,J,1) - (IRSYMM(I,J,NSA) * IN) 110 CONTINUE 120 CONTINUE 130 CONTINUE NSMAX = NS CALL EQTRVS ( NSMAX, IQTRVS ) DO 230 NS = 1,NSMAX DO 220 I=1,3 DO 210 J=1,3 D1G2F(I,J,NS) = ISM(I,J,NS) * GRISTP(J) 210 CONTINUE 220 CONTINUE 230 CONTINUE RETURN END SUBROUTINE EQTRVS ( NSMAX, IQTRVS ) PARAMETER (MAXIQ = 360) DIMENSION IQTRVS(MAXIQ) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48) DIMENSION ISM(3,3,48), ISMEQ(3,3) EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) ) INQ = 0 DO 160 NI = 2, NSMAX IF ( MAXIQ-INQ .LT. 5 ) GOTO 200 INQL = INQ + 1 IQTRVS(INQL) = NI DO 140 NIM = 2, NI IF (NIM.NE.NI) THEN IS1 = 1 ELSE IS1 = 2 ENDIF DO 120 ISIM = IS1, NSYMM CALL IMAXMA ( IRSYMM(1,1,ISIM), ISM(1,1,NI), ISMEQ ) IEQM = IARREQ( ISMEQ, ISM(1,1,NIM), 9 ) IF (IEQM .EQ. 1 .OR. IEQM .EQ. -1) THEN IF ( MAXIQ-INQL .LT. 4 ) GOTO 150 INQL = INQL + 1 IQTRVS(INQL) = NIM INQL = INQL + 1 IQTRVS(INQL) = ISIM * IEQM ENDIF 120 CONTINUE 140 CONTINUE 150 IF (INQL .NE. INQ+1) THEN INQL = INQL + 1 IQTRVS(INQL) = 0 INQ = INQL ENDIF 160 CONTINUE 200 IQTRVS(INQ+1) = 0 RETURN END SUBROUTINE IMAXMA( IA, IB, IAXIB ) DIMENSION IA(3,3), IB(3,3), IAXIB(3,3) DO 200 L = 1,3 DO 100 K = 1,3 IAXIB(L,K) = IA(L,1)*IB(1,K) + IA(L,2)*IB(2,K) + IA(L,3)*IB(3,K) 100 CONTINUE 200 CONTINUE RETURN END FUNCTION IARREQ( IA, IB, N) DIMENSION IA(N), IB(N) DO 200 I = 1, N IF ( IA(I) .NE. IB(I) ) THEN DO 100 J = 1, N IF ( IA(J) .NE. -IB(J) ) THEN IARREQ = 0 RETURN ENDIF 100 CONTINUE IARREQ = -1 RETURN ENDIF 200 CONTINUE IARREQ = 1 RETURN END SUBROUTINE VECCAL ( FXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW ) DIMENSION FXYZ(3, NAT), IZATOM( NAT) PARAMETER (MAXASV = 3600) LOGICAL LALLOW(MAXASV) LOGICAL ASYMNW COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXVEC = 960) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) LOGICAL VMINCH,LPTB DIMENSION RATC(3), ORIGIN(3), SYQDAT(3) DATA ORIGIN / 0.,0.,0. / DATA NSBEF / 0 / IF (NSBEF .EQ. 0) THEN NSBEF = 1 CALL KERNZI (0, IPOASV, 48) ASYMNW = .TRUE. ENDIF VMINCH = .TRUE. LPTB = .FALSE. IF (ICENT.EQ.1) THEN IN2 = 1 ELSE IN2 = -1 ENDIF NASV = 0 NS = 0 DO 180 IN = 1,IN2,-2 DO 170 NSA= 1,NSYMM NS = NS + 1 NALL = 0 DO 160 J = 1, NAT CALL SYMEQU (NSA, 1, 0, IN, .TRUE., FXYZ(1,J), RATC, SYQDAT) J1 = J IF (NS .EQ. 1) J1 = J + 1 DO 130 K = J1, NAT IF ( J .NE. K ) NALL = NALL + 1 IF (NALL .EQ. 0) THEN LPTB = .FALSE. ELSE LPTB = LALLOW(NALL) ENDIF IF (LPTB .OR. J .EQ. K) THEN NASV = NASV + 1 CALL VMINV ( FXYZ(1,K), RATC, ASVECT(1,NASV), 3) IF (ISELFG( ASVECT(1,NASV), ORIGIN, VMINCH, VMIN, VOUTSQ ) * .EQ.1) THEN NASV = NASV - 1 GOTO 130 ENDIF NA1A2(1,NASV) = J NA1A2(2,NASV) = K ASVECT(4,NASV) = IZATOM(J) * IZATOM(K) IF (K.EQ.J) ASVECT(4,NASV) = ASVECT(4,NASV) / 2. IF (ICENT .EQ. 2) ASVECT(4,NASV) = 2. * ASVECT(4,NASV) ENDIF 130 CONTINUE 160 CONTINUE ASYMNW = ASYMNW .OR. IPOASV(NS).NE.NASV IPOASV(NS) = NASV 170 CONTINUE 180 CONTINUE RETURN END SUBROUTINE SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQ, XS) LOGICAL FIRST DIMENSION X(3), XEQ(3), XS(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) IF (FIRST) THEN DO 120 I2 = 1,3 XS(I2) = 0. DO 110 I1 = 1,3 IF (IRSYMM(I2,I1,NS) .NE. 0) THEN IF (IRSYMM(I2,I1,NS) .EQ. 1) THEN XS(I2) = XS(I2) + X(I1) ELSE XS(I2) = XS(I2) - X(I1) ENDIF ENDIF 110 CONTINUE 120 CONTINUE IF (ITS .EQ. 1) CALL VPLUSV (XS, TSYMM(1,NS), XS, 3) CALL KERNAB (XS, XEQ, 3) ELSEIF (INV .EQ. -1) THEN XEQ(1) = -XEQ(1) XEQ(2) = -XEQ(2) XEQ(3) = -XEQ(3) RETURN ENDIF IF (NLT .GT. 1) CALL VPLUSV ( XS, TLATT(1,NLT), XEQ, 3) IF (INV .EQ. -1) THEN XEQ(1) = -XEQ(1) XEQ(2) = -XEQ(2) XEQ(3) = -XEQ(3) ENDIF RETURN END FUNCTION ISELFG (X, Y, DMINCH, DMIN, DISTSQ) LOGICAL DMINCH DIMENSION X(3), Y(3) DIMENSION DM(3), D(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DATA DMINSQ /1.0/ ISELFG=0 IF ( DMINCH ) THEN DO 110 I=1, 3 DM(I)=ABS (RCELL(I)*DMIN) 110 CONTINUE DMINSQ=DMIN*DMIN DMINCH=.FALSE. ENDIF DO 120 I=1, 3 D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I)) IF (ABS (D(I)).GT.DM(I)) RETURN 120 CONTINUE DISTSQ=0.0 DO 130 I=1, 3 DISTSQ=DISTSQ+ * D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3)) 130 CONTINUE IF (DISTSQ.LE.DMINSQ) THEN ISELFG=1 ENDIF RETURN END SUBROUTINE VECSET (ASYMNW) LOGICAL ASYMNW PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48) LOGICAL OWCINP OWCINP = .FALSE. CALL OVLTAB IF ( ASYMNW ) CALL SELVEC ASYMNW = .FALSE. DO 120 J = 1, NVV JA = INDXHV(J) DO 110 I = 1,3 VECT(I,J) = ASVECT(I,JA) 110 CONTINUE VECT(4,J) = ASVECT(5,JA) 120 CONTINUE RETURN END SUBROUTINE OVLTAB PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) LOGICAL FIRST, ALLSEQ LOGICAL CONOVL, EQUIVV DIMENSION VEXYZ(3), SYQDAT(3) INW = 0 NVECT1 = 1 LHP = 0 DO 99 NVSET = 1, NSMAX IF (1 .LE. IPOASV(NVSET) ) THEN NVSET1 = NVSET GOTO 100 ENDIF 99 CONTINUE RETURN 100 CONTINUE DO 101 NV = NVECT1, NASV ASVECT(5,NV) = ASVECT(4,NV) ASVECT(6,NV) = 0.0 101 CONTINUE DO 1100 NVSET = NVSET1, NSMAX IF (NVSET .NE. NVSET1) NVECT1= IPOASV(NVSET-1) + 1 NVEND = IPOASV(NVSET) DO 1000 NV = NVECT1, NVEND NVA = NV - 1 LHP = NV - 1 IOVLB1 = 0 IOVLB2 = 0 NS = 1 NLT= 1 INV= 1 FIRST = .TRUE. ALLSEQ = .FALSE. 111 CALL SYMEQU (NS,0,NLT,INV, FIRST, ASVECT(1,NV), VEXYZ, SYQDAT) INVXNS = INV * NS I1 = 1 DO 130 IVS = 1, NVSET CALL GEQTVS (NVSET, IVS, INVXNS, CONOVL) IF (.NOT. CONOVL) GOTO 130 IF (INW .NE. 5) THEN INW = 5 ENDIF IF (IVS .NE.1 ) I1 = IPOASV(IVS-1) + 1 IEND = IPOASV(IVS) IF (IEND .GT. NVA) IEND = NVA DO 120 I = I1, IEND IF ( ISELGG( VEXYZ, ASVECT(1,I), RMAX, RR2 ) * .EQ. 1 ) THEN EQUIVV = I .EQ. NV W1 =ASVECT(INW,NV) W2 =ASVECT(INW,I) CALL COVERW(ASVECT(4,NV), W1, ASVECT(4,I), W2, EQUIVV, RR2) ASVECT(INW,NV) = W1 ASVECT(INW,I) = W2 IF (INV .EQ. 1) THEN INS = NS ELSE INS = NS + NSYMM ENDIF IOVLB1 = INS IOVLB2 = NLT ENDIF 120 CONTINUE 130 CONTINUE NVA = NV CALL NEXSYM (NS,NLT,INV, NSYMM,NLATT, FIRST, ALLSEQ) IF (.NOT. ALLSEQ) GOTO 111 1000 CONTINUE 1100 CONTINUE IOVLB1 = 0 IOVLB2 = 100 RETURN END SUBROUTINE GEQTVS (NVSET, IVS, INS, CONOVL) LOGICAL CONOVL PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) IF (NVSET .EQ. 1) THEN CONOVL = .TRUE. RETURN ENDIF IF (NVSET .EQ. IVS .AND. INS .EQ. 1) THEN CONOVL = .TRUE. RETURN ENDIF CONOVL = .FALSE. INQL = 0 101 INQ1 = INQL + 1 IF (IQTRVS(INQ1) .EQ. 0) THEN RETURN ENDIF IF (IQTRVS(INQ1) .LT. NVSET) THEN 102 INQL = INQL + 1 IF (IQTRVS(INQL) .NE. 0 ) GOTO 102 GOTO 101 ENDIF IF (IQTRVS(INQ1) .GT. NVSET) RETURN INQ1 = INQ1 + 1 DO 200 INQ = INQ1, MAXIQ, 2 IF (IQTRVS(INQ) .EQ. IVS) THEN IF (IQTRVS(INQ+1) .EQ. INS) THEN CONOVL = .TRUE. RETURN ENDIF ELSE IF (IQTRVS(INQ) .EQ. 0 .OR. IQTRVS(INQ) .GT. IVS) RETURN ENDIF 200 CONTINUE RETURN END SUBROUTINE COVERW( WI1, W1, WI2, W2, EQUIVV, RR2) LOGICAL EQUIVV COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) IF ( RR2 .LE. RMAX2 ) THEN G = RR2/DEL + 1. IG = G F = G - FLOAT(IG) OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F W1 = W1 + OVRLAP * WI2 IF (.NOT. EQUIVV) * W2 = W2 + OVRLAP * WI1 ENDIF RETURN END SUBROUTINE NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ) LOGICAL SMOD, ALLSEQ IF (INV .EQ. 1) THEN INV = -1 SMOD = .FALSE. GOTO 110 ENDIF IF (INV .EQ. -1) INV = 1 IF (NLT .NE. 0) THEN IF (NLT .GE. NLATT) THEN NLT = 1 ELSE NLT = NLT + 1 SMOD = .FALSE. GOTO 110 ENDIF ENDIF NS = NS + 1 SMOD = .TRUE. 110 ALLSEQ = NS .GT. NSYMM RETURN END SUBROUTINE SELVEC COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 PARAMETER (MAXVEC = 960) PARAMETER (MAXASV = 3600) PARAMETER (MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) COMMON /IMSEFU/ MSUM, AMINMN, AMINMX COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) LOGICAL DMICH DIMENSION NDELV(48) PARAMETER (IFRAC = 1) PARAMETER (MXV = 100) PARAMETER (MSUMI = 3) DATA MINASV,MINNV2,MXAV1,MXAV2,MXAV4 /0,0,24, 48, IFRAC*MXV/ MXAV3 = IFRAC*MXAV2 IF (MXAV2 .GT. MAXVEC/NSMAX) THEN MXAV2=MAXVEC/NSMAX IF (MXAV1 .GE. MXAV2) MXAV1=MXAV2-1 MXAV3=IFRAC*MXAV2 ENDIF MINASV = MAXASV MAXXAV = 0 J1 = 0 DO 110 NS = 1, NSMAX NASVCS = IPOASV(NS) - J1 IF (MINASV .GT. NASVCS) MINASV = NASVCS IF (MAXXAV .LT. NASVCS) MAXXAV = NASVCS J1 = IPOASV(NS) 110 CONTINUE IF (MINASV.GT.MXAV4) THEN MAXNVS = MXV ELSE IF (MINASV.GT.MXAV3) THEN MAXNVS = MINASV/IFRAC ELSE IF (MINASV.GT.MXAV2) THEN MAXNVS = MXAV2 ELSE IF (MINASV.GT.MXAV1) THEN MAXNVS = MINASV ELSE MAXNVS = MAXXAV IF (MAXNVS .GT. MXAV1) MAXNVS = MXAV1 ENDIF IF (MAXNVS .GT. MAXVEC/NSMAX) MAXNVS = MAXVEC/NSMAX J1 = 0 IF ( MINASV .GT. MXAV2) THEN MINVCS = MXAV2 ELSE IF ( MINASV .GT. MXAV1) THEN MINVCS = MINASV ELSE MINVCS = MXAV1 ENDIF DO 120 NS = 1, NSMAX NDELV(NS) = IPOASV(NS) - J1 - MINVCS IF (NDELV(NS) .LT. 0) NDELV(NS) = 0 J1 = IPOASV(NS) 120 CONTINUE MINNVS = MAXNVS MINNV2 = MAXNVS DMICH =.TRUE. DMIN = RMAX * 0.75 JA1 = 1 JVEC1 = 1 DO 500 NS = 1, NSMAX IF (NS .NE. 1) THEN JA1 = IPOASV(NS-1) + 1 JVEC1 = IPVECT(NS-1) + 1 ENDIF NASVCS = IPOASV(NS) - JA1 + 1 NHIGST = NASVCS CALL DETSEQ (INDXHV(JVEC1),NHIGST, ASVECT(1,JA1),6,NASVCS, 5,0) J = JVEC1 JJ = JVEC1 NRESTA = NASVCS IF (MINASV .LE. MXAV2) THEN NDVMIN = NDELV(NS) ELSE NDVMIN = NASVCS - MAXNVS ENDIF NCLOSE = 0 200 CONTINUE IF (NRESTA+NCLOSE .EQ. NDVMIN .OR. NRESTA .EQ. 0) GOTO 401 JA = INDXHV(JJ) + JA1 - 1 JJ = JJ + 1 NRESTA = NRESTA - 1 INDXHV(J) = JA J = J + 1 GOTO 200 401 CONTINUE IF (MINNVS .GT. J-JVEC1) MINNVS = J-JVEC1 IF (NS.GT.1) THEN IF (MINNV2 .GT. J-JVEC1) MINNV2 = J-JVEC1 ENDIF IPVECT(NS) = J - 1 IF (NS.EQ.1) INDVEC(1)= 0 IF (NS.NE.NSMAX) INDVEC(J)= 0 500 CONTINUE IF (MINASV .GT. MXAV2) THEN MAXNVS=MINNVS J1 =0 J2 =0 JA1=0 DO 630 NS = 1,NSMAX DO 610 J= J1+1, J1+MINNVS J2 = J2+1 INDXHV(J2)=INDXHV(J) 610 CONTINUE J1=IPVECT(NS) IPVECT(NS)=J2 IF(NS.NE.NSMAX) INDVEC(J2+1)= 0 NDELV(NS) =IPOASV(NS)-JA1 - MINNVS JA1=IPOASV(NS) 630 CONTINUE ENDIF NVV = IPVECT(NSMAX) IF (MSUM .GT. MINNV2*FRACM) MSUM = MINNV2 * FRACM IF (MSUM .LT. MSUMI) MSUM=MSUMI IF (MSUM .GT. MINNV2-2) MSUM=MINNV2-2 IF (MSUM .GT. MINNVS) * MSUM=MINNVS IF (MSUM .LE. 0) MSUM=1 RETURN END SUBROUTINE CALISF(FXYZ,NAT,MSUM, SMINML,VALISF) DIMENSION FXYZ(3, NAT), SMINML(NSMAX), VALISF(5) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 PARAMETER (MAXATT = 993) COMMON /ATNAMA/ ATNAME(MAXATT) CHARACTER * 6 ATNAME PARAMETER (MAXVEC = 960, MAXASV = 3600, MAXIQ = 360) COMMON /VCTSET/ NSMAX, NASV, ASVECT(6, MAXASV), IPOASV(48), * NA1A2(2,MAXASV), * MINNVS,NVV, VECT(6, MAXVEC), IPVECT(48), * INDXHV(MAXASV), INDVEC(MAXVEC), * IQTRVS(MAXIQ) LOGICAL FIRST DATA FIRST, VALUMN /.TRUE., -1.0E+15/ DATA VALUMX / 1.0E+15 / AMNMIN = VALUMN ISFTYL = 1 INDVEC(1) = 0 DO 101 NS = 1, NSMAX-1 101 INDVEC( IPVECT(NS)+1 ) = 0 TMIM = VALUMX TSUM = 0. CALL SUPTAM ( AMNMIN, MSUM, VECT, NVV, * IPVECT, NSMAX, INDVEC, SMINML, TMIM,TSUM) MALL = NSMAX * MSUM IF (MALL.GT.200) MALL = 200 CALL ISF( MALL, VECT, NVV, TMINM) SUM2= 0.0 SMIN2= SMINML(2) DO 140 NS = 2, NSMAX SUM2= SUM2+ SMINML(NS) IF (SMIN2 .GT. SMINML(NS)) SMIN2=SMINML(NS) 140 CONTINUE VALISF(1) = SMIN2 VALISF(2) = TMIM VALISF(3) = TMINM VALISF(4) = TSUM VALISF(5) = SUM2 IF (FIRST) THEN FIRST = .FALSE. JA1 = 0 JS1 = 0 DO 300 NS = 1, NSMAX NAVSET = IPOASV(NS)-JA1 JA1 = IPOASV(NS) NSVSET = IPVECT(NS)-JS1 JS1 = IPVECT(NS) 300 CONTINUE ENDIF INDVEC(1) = 0 DO 111 NS = 1, NSMAX-1 111 INDVEC( IPVECT(NS)+1 ) = 0 RETURN END SUBROUTINE ISF( M, VECT, NVV, TMINM) DIMENSION VECT(6,NVV), INXLPW(200) DO 110 N = 1,NVV 110 VECT(5,N)=-VECT(5,N) CALL DETSEQ(INXLPW,M, VECT, 6, NVV, 5, 0) DO 120 N = 1,NVV 120 VECT(5,N)=-VECT(5,N) TSUMP = 0.0 TSUMW = 0.0 DO 210 IN = 1,M N = INXLPW(IN) TSUMP = TSUMP + VECT(6,N) TSUMW = TSUMW + VECT(4,N) 210 CONTINUE TMINM = TSUMP/TSUMW RETURN END SUBROUTINE SUPTAM ( AMINMN, MSUM, VECT, NVV, * IPVECT, NSM, INDVEC, SMINML, TMIMAP, TSUMAP) DIMENSION VECT(6,NVV), IPVECT(NSM), INDVEC(NVV), SMINML(NSM) LOGICAL TDONE NS1 = 1 DO 400 NS = NS1, NSM IF ( TDONE ( AMINMN, TMIMAP) ) THEN SMINML(NS) = 0.0 GOTO 400 ENDIF IF (NS. NE. 1) THEN J1 = IPVECT(NS-1) + 1 ELSE J1 = 1 ENDIF NVECS = IPVECT(NS) - J1 + 1 CALL MINMVS (MSUM, AMINMN,VECT(1,J1),NVECS,INDVEC(J1), SMINML(NS)) WSMINM = SMINML(NS) IF (WSMINM .LT. TMIMAP) TMIMAP = WSMINM 400 CONTINUE RETURN END SUBROUTINE MINMVS (MSUM, AMINMN, VECT, NVECS, INDVEC, SMINML) DIMENSION VECT(6,NVECS),INDVEC(NVECS) DO 110 N = 1, NVECS 110 INDVEC(N) = N SUMP = 0. SUMW = 0. DO 200 JSEQ = 1, NVECS I = INDVEC(JSEQ) CALL RDFUN ( VECT(1,I), PFUNF ) VECT(6,I) = PFUNF VECT( 5,I) = VECT(6,I) / VECT( 4,I) CALL UPISF (SMINML, SUMP, SUMW, JSEQ, MSUM, VECT, * INDVEC, NVECS) 200 CONTINUE RETURN END SUBROUTINE UPISF ( SMINML, SUMP, SUMW, J, M, * VECT, INDVEC, NVECS ) DIMENSION VECT(6,NVECS), INDVEC( NVECS ) IJ = INDVEC(J) IF (J.GT.M) THEN IM = INDVEC(M) IF ( VECT(5,IM) .LE. VECT(5,IJ) ) RETURN SUMP = SUMP + VECT(6,IJ) - VECT(6,IM) SUMW = SUMW + VECT(4,IJ) - VECT(4,IM) ELSE SUMP = SUMP + VECT(6,IJ) SUMW = SUMW + VECT(4,IJ) IF (J .LT. M) RETURN ENDIF SMINML = SUMP/SUMW IF (J.GT.M) THEN MC=INDVEC(M) INDVEC(M)=INDVEC(J) INDVEC(J)=MC ENDIF PWMAX = VECT( 5,INDVEC(M) ) IMAX = M MMIN1 = M-1 DO 100 I = 1,MMIN1 II = INDVEC(I) IF (VECT(5,II) .GT. PWMAX) THEN PWMAX = VECT(5,II) IMAX = I ENDIF 100 CONTINUE IF (IMAX .EQ. M ) RETURN MC = INDVEC(M) INDVEC(M) = INDVEC(IMAX) INDVEC(IMAX) = MC RETURN END LOGICAL FUNCTION TDONE ( AMINMN, TMMAP) TDONE = .FALSE. TDONE = TMMAP .LT. AMINMN RETURN END SUBROUTINE RDFUN (ARG, FUNF) DIMENSION ARG(3) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY) PARAMETER (NUMTAB = 200000) COMMON / / TTT, ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), TTT) DIMENSION IFAR(3), INEAR(3), RARG(3), FM(3) EQUIVALENCE (IXFAR,IFAR(1)), (IYFAR,IFAR(2)), (IZFAR,IFAR(3)) EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3)) EQUIVALENCE (RX,RARG(1)), (RY,RARG(2)), (RZ,RARG(3)) EQUIVALENCE (FMX,FM(1)), (FMY,FM(2)), (FMZ,FM(3)) DO 301 J= 1, 3 RARG(J) = AMOD(ARG(J),1.0) IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0 301 CONTINUE CALL SYMM (RX, RY, RZ) DO 599 IX=1,3 T = RARG(IX) * GTXYZ(IX) IF (T) 540, 550, 550 540 T = T - 1. 544 I = IFIX(T) IF (I.GE.-LXYZ(IX)) GOTO 555 T = T + 0.01 GOTO 544 550 I = IFIX(T) IF (I.LT.LXYZ(IX)) GOTO 555 T = FLOAT(I) - 0.01 GOTO 550 555 F=T-FLOAT(I) IF (F) 560,590,570 560 F=F+1.0 570 IF (F-0.5) 590,580,580 580 FM(IX) = 1. - F IFAR(IX)=I INEAR(IX)=I+1 GOTO 599 590 FM(IX) = F INEAR(IX)=I IFAR(IX)=I+1 599 CONTINUE K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC IJX = ITAB(K111) FUNF = FLOAT( IJX ) / 99. FUNNER=FUNF K211=K111-IXNEAR+IXFAR K121=K111+NX*(IYFAR-IYNEAR) K112=K111+NXY*(IZFAR-IZNEAR) IJX = ITAB(K211) FUNX = FLOAT( IJX ) / 99. IJX = ITAB(K121) FUNY = FLOAT( IJX ) / 99. IJX = ITAB(K112) FUNZ = FLOAT( IJX ) / 99. FUNF = FUNF * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ I1=IZFAR*NXY I2=IYFAR*NX K222 = I1 + I2 + IXFAR - NUMC K122=K222-IXFAR+IXNEAR K212=K222-I2+NX*IYNEAR K221=K222+NXY*IZNEAR-I1 FMXY=FMX*FMY FMXZ=FMX*FMZ FMYZ=FMY*FMZ FMXYZ=FMX*FMYZ IJX = ITAB(K222) FUNFAR = FLOAT( IJX ) / 99. T1=FMYZ-FMXYZ IJX = ITAB(K122) FUNYZ = FLOAT( IJX ) / 99. T2=FMXZ-FMXYZ IJX = ITAB(K212) FUNXZ = FLOAT( IJX ) / 99. IJX = ITAB(K221) FUNXY = FLOAT( IJX ) / 99. FUNF=FUNF+ FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ + 1(FMXY-FMXYZ)*FUNXY+FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ) 1 -FUNY*(T1+FMXY) - FUNX*(T2+FMXY) RETURN END SUBROUTINE SYMM (X, Y, Z) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) EQUIVALENCE (KLAUE, KEYS(6)) GOTO (5, 15, 25, 35), KLAUE 5 IF (X.GE.0.0) RETURN X = -X Y = -Y Z = -Z RETURN 15 Y = ABS(Y) IF (X.GE.0.0) RETURN X = -X Z = -Z RETURN 25 X = ABS(X) Y = ABS(Y) Z = ABS(Z) RETURN 35 Z = ABS(Z) IF (X.GE.0.0) RETURN X = -X Y = -Y RETURN END SUBROUTINE SQMODL (MMOD, INHVAM, MMODB) DIMENSION INHVAM(MMOD) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IATOMS, IFILE(1)) EQUIVALENCE (IATOLD, IFILE(2)), (IDDSY, IFILE(3)) EQUIVALENCE (ICOND, IFILE(4)) EQUIVALENCE (IKLAD, IFILE(20)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(3,50), GRIDS1 DIMENSION VAMINM(50), VAMI(5) CHARACTER *6 REMARK(1) CHARACTER *6 CBOTS, TBOTS DATA REMARK /'REMARK'/ REFMAM = .75 WRITE (LIS2, FMT='('' REFMAM ='',F5.2)') REFMAM WRITE(LIS1,FMT='('' Results for all input models, sorted'', * '' on CFOM = TRACOR * TRAVEC * 10'')') WRITE(LIS1,FMT='('' Shift # FOM FOM '')') WRITE(LIS1,FMT='('' TV= TR= CFOM TRACOR TRAVEC '', * '' R2 '')') WRITE(LIS2,FMT='('' Results for all input models, sorted'', * '' on CFOM = TRACOR * TRAVEC * 10'')') WRITE(LIS2,FMT='('' Shift # FOM FOM '', * '' Nr of Vectors Select for MIN(%)'')') WRITE(LIS2,FMT='('' TV= TR= CFOM TRACOR TRAVEC '', * '' R2 all sel MIN 20% 30% 50% '')') REWIND IKLAD REWIND IATOMS NRMODL = 0 DO 510 N = 1, MMOD 501 CALL KERINA(IKLAD, REMARK, 1, LEND) IF (LEND .EQ. -1) GOTO 511 IF (NLUSER(1).LE.0) GOTO 501 NRMODL = NRMODL +1 VAMINM(NRMODL) = FNUM(2) 510 CONTINUE 511 N=NRMODL CALL DETSEQ (INHVAM, NRMODL, VAMINM, 1, N, 1, 0) IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3)) IBOX = 0 DO 531 N=1,NRMODL REWIND IKLAD DO 521 I=1,INHVAM(N) 520 CALL KERINA(IKLAD, REMARK, 1, LEND) IF (LEND .EQ. -1) GOTO 531 IF (NLUSER(1).LE.0) GOTO 520 521 CONTINUE READ (CHIN, FMT= '(9X,I3,3F6.3,2I4,I3,5F6.3)') * NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5) R2X = FLOAT(IFOMX(3, NOMODL)) / 1000. WRITE (LIS1, FMT= '(2I4,F8.3,2F7.3, F7.3 )') * N, NOMODL, AMINMX, VAMI(5), VAMI(1), R2X WRITE (LIS2, FMT= '(2I4,F8.3,2F7.3,1X, F6.3, 2X, 3I4, 4X,4F6.3)') * N, NOMODL, AMINMX, VAMI(5), VAMI(1), R2X, * NASV, NVV, MALL, (VAMI(I),I=2,4) IFOM = NINT (AMINMX * 1000.) IBOTS = IFOMX(2, NOMODL) IF (N .EQ. 1) IBOX = IBOTS IF (IBOTS .GT. 0) THEN CALL KERI2C (IBOTS, TBOTS, 2) CBOTS(5:6) = TBOTS(1:2) CBOTS(1:4) = ' X= ' ELSE CBOTS = ' ' ENDIF WRITE (IATOMS, 102) CCODE, IT, KEYS(13), N, R2X, IFOM, CBOTS 102 FORMAT ('ATOMS ', A6, ' < TRAVEC', I7, * ' RUN', I4, ' TV=', I3,' R2= ', F6.3, ' FOM=', I5, A6) WRITE(CHIN, FMT= '(''REMARK from TR='',I3,'' FOM based '', * ''on TRACOR+TRAVEC :'',F6.3, '' (not on R2)'')') NOMODL, AMINMX 522 WRITE (IATOMS, FMT='(A80)') CHIN CALL KERINA(IKLAD, REMARK, 1, LEND) IF (LEND .NE. 4) GOTO 522 WRITE (IATOMS, FMT='(''END'')') 531 CONTINUE CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') REWIND IKLAD CALL FILCLO (IKLAD, 'DELETE') IF (IBOX .GT. 0) GOTO 801 WRITE (LIS1, 710) WRITE (LIS2, 710) 710 FORMAT (/ * ' The first accepted parameter set is transferred to PHASEX.' / * ' All accepted parameter sets are written to the ATOLD file,' / * ' for use in case the first set does not lead to the correct'/ * ' structure.' ) WRITE (LIS2, 711) 711 FORMAT ( * ' Note:' / * ' All accepted parameter sets are written to the ATOMS file,' / * ' but DDMAIN + PHASEX are going to use only the first set.') RETURN 801 CONTINUE WRITE (IPR1, 810) WRITE (LIS1, 810) WRITE (LIS2, 810) 810 FORMAT (/ * ' All parameter sets are written to the ATOMS file, sorted.' / * ' The first and best ATOMS set, however, is not acceptable.' / * ' The molecule collides with symmetry related molecules !!!!' / * ' You may decide what is best to do next ... We will STOP' / * ' If the molecule is on a symmetry element, then use your' / * ' local software to generate a symmetry independent fragment' / * ' to be stored in the ATOMS file, and then continue with' / * ' DIRDIF CCODE PHASEX for completion of the structure. !!!!!' ) CALL FILINQ (IDDSY, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IDDSY, FMT='(''STOP'')') CALL FILCLO (IDDSY, 'KEEP') CALL KEPROX RETURN END FUNCTION ISELFC( XC1, XC2, DMIN, DOUT ) DIMENSION XC1(3), XC2(3), D(3) ISELFC = 0 DO 100 I = 1,3 D(I) = ABS( XC1(I) - XC2(I) ) IF ( D(I) .GT. DMIN ) RETURN 100 CONTINUE DMINSQ = DMIN * DMIN DOUT = D(1)*D(1) + D(2)*D(2) + D(3)*D(3) IF (DOUT .GT. DMINSQ) RETURN DOUT = SQRT( DOUT ) ISELFC = 1 RETURN END FUNCTION ISELGG (X, Y, DMAX1, DISTSQ) DIMENSION X(3),Y(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION DM1(3), D(3) LOGICAL DMA1CH DATA DMASQ1 /0.0/ DATA DMA1CH /.TRUE./ IF ( DMA1CH) THEN DO 110 I=1, 3 DM1(I)=ABS (RCELL(I)*DMAX1) 110 CONTINUE DMA1CH=.FALSE. DMASQ1=DMAX1*DMAX1 ENDIF ISELGG = 0 DO 130 I=1, 3 D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I)) IF ( ABS(D(I)) .GT. DM1(I) ) RETURN 130 CONTINUE DISTSQ=0.0 DO 140 I=1, 3 DISTSQ=DISTSQ+ * D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3)) 140 CONTINUE IF (DISTSQ .GT. DMASQ1) RETURN ISELGG=1 RETURN END SUBROUTINE VPLUSV (V1, V2, VOUT, N) DIMENSION V1(N), V2(N), VOUT(N) DO 110 I = 1, N VOUT(I) = V1(I) + V2(I) 110 CONTINUE RETURN END SUBROUTINE VMINV (V1, V2, VOUT, N) DIMENSION V1(N), V2(N), VOUT(N) DO 110 I = 1, N VOUT(I) = V1(I) - V2(I) 110 CONTINUE RETURN END SUBROUTINE ATMOUT (IUNIT, CCODE, REMARK, ATNAME, NNAMS, XYZ, NAT) CHARACTER*6 CCODE, ATNAME(NNAMS) CHARACTER*8 REMARK(10) DIMENSION XYZ(3,NAT) IF (REMARK(1) .NE. 'REMARK ') THEN WRITE(IUNIT,FMT='(''ATOMS'',5X,A6,6A8)') CCODE,(REMARK(I),I=1,6) ELSE WRITE(IUNIT,FMT='(''ATOMS'', 5X,A6)' ) CCODE WRITE (IUNIT, FMT='(10A8)' ) REMARK ENDIF NAMI = 1 DO 110 I = 1,NAT IF (I.LE.NNAMS) NAMI=I WRITE (IUNIT, FMT='(''ATOM '', A6, 3F10.5)' ) * ATNAME(NAMI), (XYZ(J,I),J=1,3) 110 CONTINUE WRITE (IUNIT, FMT='(''END'')') RETURN END