PROGRAM PATTY ********************************************** Last update: 11 Nov. 1999 ********************************************** Source: G.Admiraal +HB+CS C Subroutine SYMM is common to ORIENT, PATTY and TRAVEC C Warning: this subroutine maybe different: do not reject : check! C NAT=1 naar DDLOG: beslissing hoort in DDMAIN wegens verdere selectie * backup: PATTY.FEB * PATTY LOG of recent modifications (last on top PARAMETER (MXPKS=150, MXPEAK=MXPKS+100) DIMENSION XP(5, MXPEAK) PARAMETER (MXHEAV=20,MXSTSX=30) DIMENSION XZ(5*MXHEAV+5,MXSTSX) 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)), (IPDEK, IFILE(14)) EQUIVALENCE (IPR1, IFILE(6)), (LIS2, IFILE(8)) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /ELEMB/ ACELTY(10) CHARACTER*2 ACELTY COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (MXPP=128) COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD CALL KEPROG ('PATTY') WRITE (LIS2, FMT = '('' Last PATTY update: 11 Nov. 1999'')') CALL PREPRO CALL ELEMS CALL PATHVY (PFMAPX, PORIGI, SCPAT, PLIM, VP,NVPS, XZ, NSTSXZ) IF (NSTSXZ.GE.1 .AND. NCONS.LE.2) GOTO 110 PATAD = 25. CALL PREDEK (PFMAPX, PORIGI, SCPAT, PLIM, SCADEK, PATAD, PATP) SC2DEK=SCADEK PATADD=PATAD CALL PATTIN WRITE (LIS1, FMT='('' Patterson origin height:'',12X,F10.1)') * PORIGI WRITE (LIS1, FMT='('' Patterson height for a '',A2,''-'',A2, * '' vector:'',F10.1)') ACELTY(1), ACELTY(1), * SCPAT*NCELLZ(1)**2 + PATAD IF (LTHEAV .GT. 1) * WRITE (LIS1, FMT='('' Patterson height for a '',A2,''-'',A2, * '' vector:'',F10.1)') ACELTY(LTHEAV), ACELTY(LTHEAV), * SCPAT*NCELLZ(LTHEAV)**2 + PATAD CALL REMORI CALL GETOVC CALL KERNZA (0.0, XP, 5*MXPEAK) CALL SYMMPK (XP, NOP) IF (NOP.EQ.0) CALL KERROR * ('No peaks found in the symmetry map', 0, 'PATTY') CALL PROSPK (XP, NOP, XZ, NSTSXZ) IF (NSTSXZ .EQ. 0) THEN WRITE (LIS1, 106) WRITE (IPR1, 106) 106 FORMAT(/' The results from the symmetry map are not acceptable:', */' Scaling errors? B too low? Wrong H.A. in CELL contents?'/) CALL KERROR ('No solution acceptable !', 106, 'PATTY') ENDIF 110 CALL HCOOUT (XZ, NSTSXZ, 1) CALL KEPROX WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 0 END SUBROUTINE PREPRO 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 (KLAUE, KEYS(6)) EQUIVALENCE (ITPL, KEYS(7)) EQUIVALENCE (FRACIN, KEYS(25)) EQUIVALENCE (IATOMS,IFILE(1)) EQUIVALENCE (ICRYS, IFILE(3)) EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (IFMAP, IFILE(17)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4) COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP), * ASVECT(5,MAXASV),NASV CALL KERNZA (0.0, ASVECT, 5*MAXASV) CALL RDCRYS( ICRYS ) CALL FILCLO( ICRYS, 'KEEP' ) P1METH=.FALSE. IF (ICENT.EQ.1 .AND. NSYMM.EQ.1) P1METH=.TRUE. 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 IF (IUNIQ .EQ. 1) GOTO 105 KLAUE = 2 GOTO 105 103 KLAUE = 3 GOTO 105 104 KLAUE = 4 105 CONTINUE ITPL = 10 FRACIN=0.0 RETURN END SUBROUTINE TERIVA (VARNAM, VALUE) CHARACTER*8 VARNAM 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 (IPR1, IFILE(6)) 101 WRITE(IPR1, FMT ='('' '',A8,'' ='',F10.2)') VARNAM, VALUE 102 WRITE(IPR1, FMT ='('' Do you want to change the value of '', * A8,''? (Y or N)'')') VARNAM CALL KETERM (0, 1, KEND) IF (KEND .EQ. 24) RETURN IF (KEND .EQ. 35) THEN 110 WRITE(IPR1, FMT ='('' Give '',A6)') VARNAM CALL KETERM (1, 0, KEND) IF (KEND .GE. 0) THEN VALUE = FNUM(1) ELSE GOTO 110 ENDIF GOTO 101 ELSE WRITE(IPR1, FMT ='('' Answer with Y or N!'')') GOTO 102 ENDIF END SUBROUTINE TERMYN (YES) LOGICAL YES 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 (IPR1, IFILE(6)) 102 CALL KETERM (0, 1, KEND) YES=.FALSE. IF (KEND .EQ. 24) RETURN YES=.TRUE. IF (KEND .EQ. 35) RETURN WRITE(IPR1, FMT ='('' Answer with Y or N'')') GOTO 102 END SUBROUTINE ELEMS COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /ELEMB/ ACELTY(10) CHARACTER*2 ACELTY 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 (ICRYS, IFILE(3)),(LIS1, IFILE(7)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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) CALL CELZAT (ACELTY, NCELTY, NCELLZ) 100 AVZ = 0.0 TATOMS= 0.0 DO 110 N=1,NTYPE IF (NCELLZ(N).GT. 1.1) THEN AVZ = AVZ + NCELLZ(N)*NCELTY(N) TATOMS = TATOMS + NCELTY(N) ENDIF 110 CONTINUE ZMAX = NCELLZ(1) AVZ =AVZ / TATOMS IF (TATOMS/IMULT.GT.8.0 .AND. ZMAX**2.LT.1.25*AVZ**2) * CALL KERROR (' No heavy atom structure. Do not use PATTY',0, * 'ELEMS') ZHEVY = (AVZ + ZMAX)/2. IF (ZHEVY .GT. ZMAX-0.01) ZHEVY=ZMAX-0.01 WRITE(LIS1,FMT='('' Define heavy atoms:'' / * '' Heavy atoms number in asym.unit Z'')') IMULTP=IMULT IF (P1METH) IMULTP=NLATT AMULT = IMULTP AVZ=AVZ*TATOMS DO 127 NT=1,2 NHEAVY = 0 NCELH = 0 NCELHS= 0 DO 120 N=1,NTYPE NCELSP(N) = MOD(NCELTY(N),IMULTP) NASYMP(N) = NCELTY(N)/IMULTP IF (NCELSP(N).GT.0) NASYMP(N)=NASYMP(N)+1 IF (NCELLZ(N) .GT. ZHEVY) THEN LTHEAV = N IF (ZHEVY**2 .GT. 0.75*NCELLZ(N)**2) ZHEVY = 0.866*NCELLZ(N) NCONST(N) = NASYMP(N) NHEAVY = NHEAVY + NCONST(N) NCELH = NCELH + NCELTY(N) IF (ICENT.EQ.2 .AND. NCELH/NLATT.LT.3 .AND. N.EQ.1) THEN IF (ZHEVY.GT.NCELLZ(2).AND.NCELLZ(2).GT.AVZ.AND. * NCELLZ(1)**2.LT.2*NCELLZ(2)*NCELLZ(1)) ZHEVY=NCELLZ(N+1)-.01 ENDIF AVZ = AVZ - NCELTY(N)*NCELLZ(N) NCELHS= NCELHS+ NCELSP(N) ENDIF 120 CONTINUE LT1=0 LTHV=LTHEAV NCONS=NHEAVY IF (NT.EQ.2) GOTO 127 IF (TATOMS-NCELH.GT.0.99) AVZ = AVZ/(TATOMS-NCELH) IF (TATOMS/IMULTP.GT.8.0 .AND. ZMAX**2 .LT. 2.0*AVZ**2) * CALL KERROR (' No heavy atom structure. Do not use PATTY',0, * 'ELEMS') IF (NHEAVY.GT.3) GOTO 128 DO 125 L = LTHEAV+1,NTYPE-1 IF (NCELLZ(L)**2 .GT. 2.5*AVZ**2) THEN IF (.5*NCELLZ(L)**2 .GT. NCELLZ(L+1)**2) THEN ZHEVY=NCELLZ(L)-0.1 GOTO 127 ENDIF ELSE GOTO 128 ENDIF 125 CONTINUE GOTO 128 127 CONTINUE 128 CONTINUE DO 129 N=1,LTHEAV WRITE(LIS1,FMT='(3X,A2, F22.2, I11)') * ACELTY(N), NCELTY(N)/AMULT, NCELLZ(N) 129 CONTINUE HEAVYN = NCELH/AMULT IF (.NOT.P1METH .AND. * ICENT.EQ.1 .AND. NSYMM.EQ.2 .AND. ILAUE.LE.2) THEN NM=0 DO 210 I=1,3 210 IF (IRSYMM(I,I,2).EQ.-1) NM=NM+1 IF (NM.LE.1 .OR. HEAVYN.GT.2.9) P1METH=.TRUE. IF (P1METH) GOTO 100 ENDIF NELMS = NTYPE CALL FILINQ( ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN WRITE(CHOUT, 130) CCODE 130 FORMAT (' ERROR no CRYSDA file found for ', A6) CALL KERROR( CHOUT, 0, 'ELEMS') ENDIF DH1H2=2.7 CALL RDCRYB(ICRYS, 'ELEM ', KEND) IF (KEND.EQ.1) THEN READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3 NELEC1 = NELECS 211 CONTINUE IF (NELECS.GT.ZHEVY) DH1H2=AMIN1(DH1H2,2.*RAT1,2.*RAT2,2.*RAT3) CALL RDCRYB(ICRYS, 'ELEM ', KEND2) IF (KEND2.EQ.1) THEN READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3 IF (NELECS .NE. NELEC1) GOTO 211 ENDIF ENDIF DH1H2=(DH1H2-0.2)*0.9 CALL FILCLO( ICRYS, 'KEEP' ) RETURN END SUBROUTINE PREDEK(PFMAPX, PORIGI,SCPAT, PLIM, SCADEK, PATAD, PATP) DIMENSION PATP(8) 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 (LIS2, IFILE(8)) EQUIVALENCE (IDDL, IFILE(9)), (IPDEK, IFILE(14)) EQUIVALENCE (SCAKEY,KEYS(26)),(SINGPK,KEYS(27)),(ORIGIN,KEYS(28)) PARAMETER (PDEKX=254.) CALL LOGRD (IDDL, 'SINGPK', KLOG) IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PREDEK') IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR * ('DDLOG file: SINGPK a/o ORIGIN missing',-1,'PREDEK') 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,'PREDEK') 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 120 PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I))) 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'/ * ' shape = 1.000', 8F6.3 ) CALL PPROFI (PATP) SCADEK = (PDEKX-PATAD)/ PFMAPX SCAKEY = SCADEK PLIM = 0.25* PLIM * SCADEK + PATAD WRITE (LIS2, FMT='(/'' PLIM used for symmetry-map='',F9.2)') PLIM PORIGI = PORIGI * SCADEK + PATAD SCPAT = SCPAT * SCADEK RETURN END SUBROUTINE PPROFI (PATP) DIMENSION PATP(8) COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50) DATA IMAX2, DELY, DEL2Y /0, 0.0, 0.0/ DEL = 0.01 TAB(1) = 1. IXL = 0 I = 2 36 RRR = SQRT(FLOAT(I) - 0.9999) IX = RRR 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 PATHVY (PFMAPX, PORIGI, SCPAT,PLIM, VP,NVPS,XZ,NSTSXZ) PARAMETER (MXHEAV=20,MXSTSX=30,MXPP=128) DIMENSION XZ(5*MXHEAV+5,MXSTSX), VP(4,MXPP) DIMENSION INXZ(MXSTSX), X1Z(5*MXHEAV+5) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV 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 (IDDL, IFILE(9)) EQUIVALENCE (IFMAP, IFILE(17)) EQUIVALENCE (SCADEK, KEYS(26)) EQUIVALENCE (ORFMAP, KEYS(28)) 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 ITLE(20) EQUIVALENCE (ITLE(18), FFTSC) INTEGER*2 LPAT1 ZN2 = NCELLZ(1)**2 SUM = 0.0 DO 110 IE = 1, NELMS ZI2 = NCELLZ(IE)**2 NI = NCELTY(IE)/NLATT SUM = SUM + NI*ZI2 IF (IE .LE. LTHEAV) ZN2 = ZI2 110 CONTINUE CALL LOGRD (IDDL, 'SINGPK', KLOG) IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'PATHVY') IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR * ('DDLOG file incorrect, SINGPK a/o ORIGIN missing',-1,'PATHVY') ORIGIN = FNUM(3) CALL FILCLO (IDDL, 'KEEP') CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ) IF (KINQ.NE.0) CALL KERROR * ('Patterson file (FMAP) not found.', -1, 'PATHVY') READ (IFMAP) ITLE, IMAP, IHALF READ (IFMAP) READ (IFMAP) IBSEC, IBJ, IBNX, LPAT1 CALL FILCLO (IFMAP, 'KEEP') ORFMAP = 6000. PORIGI = ORFMAP SCPAT=ORFMAP/SUM PHH = SCPAT * NCELLZ(1)**2 IF (ICENT.EQ.2 .AND. NCELTY(1).GE.4) PHH=PHH+PHH PLIM = SCPAT * ZN2 PLIM2=PLIM IF (ICENT.EQ.2) PLIM2=PLIM+PLIM PFMAPX = 8.* PHH CALL RDVECA (VP,NVPS,DH1H2) IF (NVPS.GT.1) PFMAPX= VP(4,2) IF (PFMAPX .GT. 0.8*ORFMAP) PFMAPX=0.8*ORFMAP NSTSXZ=0 IF (NSYMM.NE.1 .OR. ICENT.NE.1) RETURN ISQ = 5*MXHEAV+3 X1Z(1)=0.0 X1Z(2)=0.0 X1Z(3)=0.0 X1Z(4)=1.0 X1Z(5)=NCELLZ(1) X1Z(5*MXHEAV-1)=1.0 X1Z(5*MXHEAV)=X1Z(5)*X1Z(5) X1Z(5*MXHEAV+1)=1.0 X1Z(5*MXHEAV+3)=1.0*X1Z(5*MXHEAV) CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ) NCO2=0 IF (NCONST(1).GT.1) NCO2=1 IF (NCO2.EQ.0 .AND. LTHEAV.GT.1) NCO2=2 IF (NCO2.EQ.0) RETURN X1Z(10)=NCELLZ(1) IF (NCELTY(1).LE.1) X1Z(10)=NCELLZ(2) X1Z(5*MXHEAV)=X1Z(5)**2+2*X1Z(10)*X1Z(5)+X1Z(10)**2 NMXSTS=MXSTSX+1 IF (NMXSTS.GT.NVPS) NMXSTS=NVPS DO 310 N=2,NMXSTS,1 X1Z(6)=VP(1,N) X1Z(7)=VP(2,N) X1Z(8)=VP(3,N) X1Z(9)=1.0 X1Z(10)=NCELLZ(NCO2) AMINM = VP(4,N)/(SCPAT*X1Z(10)*X1Z(5)) X1Z(5*MXHEAV-1)=AMINM AM1=AMINM AM2=0.0 IF (AM1.GT.1.3) THEN AM1=1.3 AM2=(AMINM-1.3)*0.1 ENDIF X1Z(5*MXHEAV+1)=2.0 X1Z(5*MXHEAV+3)= (AM1+AM2) * X1Z(5*MXHEAV) CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ) 310 CONTINUE MXINXZ=MXSTSX CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX) RETURN END SUBROUTINE RDVECA (VEC,NVEC,DH1H2) PARAMETER (MXPP=128) DIMENSION VEC(4,MXPP) 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 (IATOMS,IFILE(1)) 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 /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) LOGICAL READVC DIMENSION VECN(3), VEC000(3), DVEC(3) CHARACTER*6 LATM(1) DATA LATM, VEC000 / 'ATOM ', 0.,0.,0./ READVC=.FALSE. NVEC=1 VEC(1,1)=0.0 VEC(2,1)=0.0 VEC(3,1)=0.0 VEC(4,1)=30254. DHAHB = DH1H2*0.8 DHAHB2=DHAHB**2 CALL FILINQ( IATOMS,'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR * ('No ATOMS file (with Patterson pieks) found', 0, 'RDVECA') 111 CALL KERINA (IATOMS, LATM, 1, LEND) IF (LEND.NE.0) GOTO 310 IF (NLUSER(1).GT.0 .AND. NFNUM.GE.5) THEN READVC = .TRUE. IF (ABS(FNUM(2)).LT.0.01 .AND. ABS(FNUM(3)).LT.0.01 .AND. * ABS(FNUM(4)).LT.0.01 .AND. NVEC.EQ.1 ) THEN GOTO 111 ELSE VECN(1)=FNUM(2) VECN(2)=FNUM(3) VECN(3)=FNUM(4) CALL DISTSQ (VEC000, VECN, DHAHB, DVEC, RR2) IF (RR2.GT.DHAHB2) THEN NVEC=NVEC+1 CALL KERNAB(VECN,VEC(1,NVEC),3) VEC(4,NVEC)=FNUM(5) ENDIF IF (NVEC.LT.MXPP-1) GOTO 111 ENDIF ELSE IF (.NOT. READVC) GOTO 111 ENDIF 310 CONTINUE RETURN END SUBROUTINE REMORI 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 /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV DIMENSION X(3),XYZL(3),XYZS(3),XORI(3),XOR(3), * IXORI(3),IXOR(3),IXR(3),IXL(3),IX1(3),IT(3) EQUIVALENCE (IT(1),ITX),(IT(2),ITY),(IT(3),ITZ) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB STEPR=0.0 CALL KERNZA(0.0,XORI,3) DO 100 I=1,3 XYZL(I)=LXYZ(I)/GTXYZ(I) XYZS(I)=IS(I)/GTXYZ(I) CALL KERNZA(0.0,X, 3) X(I) = 1./GTXYZ(I) STEP = SQDIST(XORI,X) STEPR= STEPR + STEP STEP = SQRT(STEP) R=DH1H2-0.5*STEP IXR(I) = R/STEP 100 CONTINUE STEPR=SQRT(STEPR) R = DH1H2-0.5*STEPR R2=R*R DO 910 NL=1,NLATT DO 110 I=1,3 TLNL=TLATT(I,NL) IF (TLNL.LT.XYZS(I)) TLNL=TLNL+INT(0.999+XYZS(I)-TLATT(I,NL)) IF (TLNL.GT.XYZL(I)) TLNL=TLNL-INT(0.999+TLATT(I,NL)-XYZL(I)) IXORI(I)=NINT(TLNL*GTXYZ(I)) XORI(I)=TLNL 110 CONTINUE DO 610 ITX = -1,1,1 DO 610 ITY = -1,1,1 DO 610 ITZ = -1,1,1 DO 120 I=1,3 XOR(I)=XORI(I)+IT(I) IXOR(I)=IXORI(I)+IT(I)*NUM(I) IXL(I)=IXOR(I)+IXR(I) IF (IXL(I).LT.IS(I)) GOTO 610 IX1(I)=IXOR(I)-IXR(I) IF (IX1(I).GT.LXYZ(I)) GOTO 610 IF (IXL(I).GT.LXYZ(I)) IXL(I) = LXYZ(I) IF (IX1(I).LT.IS(I)) IX1(I) = IS(I) 120 CONTINUE DO 310 IZ = IX1(3), IXL(3) X(3)= IZ/GTXYZ(3) DO 310 IY = IX1(2), IXL(2) X(2)= IY/GTXYZ(2) DO 310 IX = IX1(1), IXL(1) X(1)= IX/GTXYZ(1) DX2= SQDIST(XOR,X) IF (DX2.LT.R2) THEN IADR = NUMXY * IZ + NUM(1) * IY + IX - NUMC ITAB(IADR) = 0 ENDIF 310 CONTINUE 610 CONTINUE 910 CONTINUE RETURN END SUBROUTINE GETOVC 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 (ICRYS, IFILE(3)) EQUIVALENCE (LIS1, IFILE(7)) 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) COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) CALL FILINQ( ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN WRITE(CHOUT, 110) CCODE 110 FORMAT (' ERROR no CRYSDA file found for ', A6) CALL KERROR( CHOUT, 0, 'GETOVC') ENDIF CALL RDCRYB(ICRYS, 'NORIG', KEND) IF (KEND.EQ.1) THEN READ (CHIN,FMT='(10X,I10)') NOR DO 210 N=1,NOR CALL RDCRYB(ICRYS, 'ORGVEC', KEND2) IF (KEND2.EQ.1) THEN READ (CHIN,FMT='(10X,3F10.7)') (ORIG(I,N),I=1,3) ELSE NOR=N-1 WRITE (LIS1, * FMT='('' ERROR CRYSDA: NUMBER OF ORIGINS < NORIG'')') GOTO 220 ENDIF 210 CONTINUE 220 IDDPOL=1 IF (IPOLA.EQ.0) IDDPOL=0 IF (IPOLA.EQ.3 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.6) IDDPOL=2 IF (IPOLA.EQ.7) IDDPOL=3 RVPOL(1)=0.0 IF (IPOLA.EQ.1 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.8) RVPOL(1)=1.0 RVPOL(2)=0.0 IF (IPOLA.EQ.2 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.8) RVPOL(2)=1.0 RVPOL(3)=0.0 IF (IPOLA.EQ.3 .OR. IPOLA.EQ.4 .OR. IPOLA.EQ.8) RVPOL(3)=1.0 ELSE WRITE(CHOUT, 310) CCODE 310 FORMAT(' ERROR no origins on CRYSDA file for ',A6 ) CALL KERROR( CHOUT, 0, 'GETOVC') ENDIF CALL FILCLO( ICRYS, 'KEEP' ) RETURN END SUBROUTINE PROSPK (XP, NOP, XZ, NSTSXZ) PARAMETER (MXHEAV=20, MXSTSX=30) DIMENSION XP(5, NOP), XZ(5*MXHEAV+5,MXSTSX) 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 (ITPL, KEYS(7)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IPR1, IFILE(6)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV PARAMETER (MXPKS=150, MXSTSP=140) DIMENSION XP2(5, MXPKS), MULORD(MXPKS), NCOSTA(MXHEAV), * PISET(MXHEAV+3,MXSTSP), X(4*MXHEAV+5,MXSTSX), PLIMF(3) LOGICAL READY, SPGP1, REDYIN DATA NCOSTA / MXHEAV*-1/ NP2 = MIN0(NOP,MXPKS) NXP = NP2 SPGP1 = NSYMM*ICENT .EQ. 1 CALL OCCUPA (P1METH, XP, XP2, NP2) IF (.NOT. P1METH) THEN WRITE (LIS1, FMT = '(/ '' Highest peaks of the symmetry map''/ * '' No. x y z height '', * ''mult.factor'')') NOPRI = MIN0 (10, NOP) DO 199 N = 1, NOPRI WRITE (LIS1, FMT='('' '',I3,2X,3F10.4,8F10.1)') * N, (XP(I,N),I=1,5) 199 CONTINUE ENDIF CALL PATHLI (XP2, NP2, NP3) NP2=NP3 WRITE(LIS2,FMT='('' Limit patterson height:'',F6.1)') PLIMS(LTHV) WRITE (LIS2, FMT='('' Symmetry-map peaks lower than this value'', *'' are ignored'')') NHP=0 ITPL = 2 IF (.NOT.P1METH .AND. IPOLA.NE.0) ITPL = 4 PLIM0=PLIMC(LTHEAV,LTHEAV) CALL CROS2P( XP2,NP2, PLIM0, MULORD, NPKS2, MAHEAV) MIHEAV=2 DO 100 I = 1, MXHEAV IF (I.LT.MIHEAV .OR. I.GT.MAHEAV) THEN NCOSTA(I)=-1 ELSE NCOSTA(I)= 1 ENDIF IF (SPGP1 .AND. I.LE.2) NCOSTA(I)=2 100 CONTINUE NPS1=0 REDYIN = .FALSE. 111 CALL EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY) CALL PATHLI (XP2, NP2, NP3) IF (.NOT. READY) THEN NEWXZ=0 CALL CROS2S (XP2,MULORD,NCOSTA,PISET,NSETS,XZ,NSTSXZ) WRITE (LIS2, FMT='('' Sets of peaks and minimum-value'')') WRITE (LIS2, FMT='('' Number of sets found:'',I3)') NSETS IF (MAHEAV .GT. 1 .AND. NSETS.GT.0) THEN NSETSX=0 PLIMF(3)=PLIMC(LTHV,LTHV) IF (NCONST(LTHV).EQ.1.AND.LTHV.GT.1) * PLIMF(3)=PLIMC(LTHV-1,LTHV) IF (LT1.GT.0 .AND. LT1.LT.LTHV) THEN PLIMF(1)=PLIMC(LT1,LT1) PLIMF(2)=PLIMC(LT1,LTHV) ELSE PLIMF(1)=PLIMF(3) PLIMF(2)=PLIMF(3) ENDIF CALL FIXONE (XP2,NPKS2, PISET,NSETS, PLIMF, X,NSETSX) CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ) ENDIF WRITE(IPR1,FMT='('' Search for'',I3,'' atoms ready'')') NCONS WRITE(LIS1,FMT='('' Search for'',I3,'' atoms ready'')') NCONS IF (NSTSXZ.GT.0) CALL HCOOUT (XZ, NSTSXZ, 0) GOTO 111 ENDIF IF (NCONS .EQ. 1) THEN IF (SPGP1) NXP=1 CALL POS1S (XP, NXP, X, NSETSX) CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ) ENDIF NPMAX=16*NLATT CALL DISCAB (XZ,NSTSXZ,NPMAX) RETURN END SUBROUTINE OCCUPA (SPGP1, X1, X2, NX) LOGICAL SPGP1 DIMENSION X1(5,NX), X2(5,NX) 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)) DIMENSION XLOCK(3) PARAMETER (DMAX=0.7) DO 210 N = 1,NX IF (.NOT.SPGP1) THEN X1(5,N) = OCCUPX( X1(1,N) ) IF (X1(5,N) .LT. 0.99) THEN CALL LOCKIN (X1(1,N), DMAX, XLOCK, DIST, NPOS) IF (DIST.GT.0.1) WRITE (LIS1,120) N,DIST,(X1(J,N),J=1,3),XLOCK 120 FORMAT (' Atom ',I3,' locked in: peak shifted over', F6.2, * ' Angstrom' / ' Peak xyz:',3F9.5, ' LOCKED xyz:',3F9.5) CALL KERNAB (XLOCK,X1(1,N),3) ENDIF ENDIF 210 CALL KERNAB (X1(1,N), X2(1,N), 5) RETURN END SUBROUTINE PATHLI (XP2, NP2, NP3) DIMENSION XP2(5, NP2) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /ELEMB/ ACELTY(10) CHARACTER*2 ACELTY 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 /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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (FRACIN, KEYS(25)) DIMENSION ILIMS(10), ILIMC(10,10) LOGICAL FIRST DATA FIRST, FRAC /.TRUE., 0.0/ DATA IFRAC / 0 / CALL KERNZA (-1. , PLIMC, 100) PLIMOL=PLIM IF (FIRST) THEN CALL KERNZI (0, ILIMS, 10) CALL KERNZI (0, ILIMC, 100) IF (P1METH) THEN PLIMTH= SCPAT * (NCELLZ(1)*NCELLZ(LTHV)) + PATAD FRAC=0.40 ATSMIN=AMAX1((HEAVYN*HEAVYN - HEAVYN)/2.0+1.0, 11.) ELSE PLIMTH= SCPAT * (NCELLZ(LTHEAV)**2) + PATAD FRAC = 0.30 ATSMIN=4.0*HEAVYN ENDIF PLIM=AMAX1((PLIMTH-PATAD)*FRAC*1.25 + PATAD, PLIMOL) ATOMS = 0.0 DO 110 N = 1, NP2 ATOMS = ATOMS + AMIN1( XP2(5,N),1.0 ) IF (ATSMIN .LT. ATOMS + 0.01) THEN IF (PLIM .GT. XP2(4,N)) PLIM=AMAX1(XP2(4,N), PLIMOL) GOTO 120 ENDIF 110 CONTINUE 120 FRAC = (PLIM-PATAD)/(PLIMTH-PATAD) FRAC = FRAC*0.8 IF (FRAC.LT.0.3) THEN FRAC=0.3 PLIM=(PLIMTH-PATAD)*FRAC+ PATAD ENDIF ENDIF IF (FRACIN.GT.0.01) FRAC=FRACIN IF (FRACIN.LT.0.01) FRACIN=FRAC KFRAC = 100.1 * FRAC IF (KFRAC .NE. IFRAC) WRITE (LIS2,FMT=' * (/'' Limit P(Patterson) ='',F5.2,'' x P(theoretical)'')') FRAC IF (KFRAC .NE. IFRAC) IFRAC = KFRAC FRACS= FRAC*1.25 FRACC= FRAC FRACHL=0.8 I1=1 IF (LT1.NE.0 .AND. LTHV.GT.LT1) I1=LT1+1 IF (FIRST) I1=1 DO 220 I = 1,NELMS IF (I.GE.I1) THEN IF (P1METH) THEN PLIMS(I) = (SCPAT*NCELLZ(1)*NCELLZ(I))*FRACS + PATAD ELSE PLIMS(I) = (SCPAT*NCELLZ(I)*NCELLZ(I))*FRACS + PATAD ENDIF IF (PLIM.GT.PLIMS(I)) PLIM=PLIMS(I) ENDIF II = 100.1 * PLIMS(I) IF (II .NE. ILIMS(I)) THEN WRITE(LIS2,FMT= * '('' Limit value selfvector of atoms '',A2, 3X, F7.1)') * ACELTY(I), PLIMS(I) ILIMS(I) = II ENDIF DO 210 J = I,LTHV IF (I.GE.I1 .OR. J.GE.I1) THEN FRACCC=FRACC IF (J.GT.LTHV) FRACCC=FRACHL PLIMC(I,J)=(SCPAT*NCELLZ(I)*NCELLZ(J))*FRACCC+ PATAD IF (J.GT.LTHV) GOTO 210 IF (PLIM.GT.PLIMC(I,J)) PLIM=PLIMC(I,J) PLIMC(J,I)=PLIMC(I,J) II = 100.1 * PLIMC(I,J) IF (II .NE. ILIMC(I,J)) THEN WRITE(LIS2,FMT= * '('' Limit value crossvector of atoms '',A2,1X,A2,F7.1)') * ACELTY(I), ACELTY(J), PLIMC(I,J) ILIMC(I,J) = II ILIMC(J,I) = II ENDIF ENDIF 210 CONTINUE 220 CONTINUE FIRST=.FALSE. DO 310 N=2,NP2 IF (XP2(4,N).LT.PLIMS(LTHV)) THEN NP3=N-1 RETURN ENDIF 310 CONTINUE NP3=NP2 RETURN END SUBROUTINE CROS2S(XP2,MULORD,NCOSTA,PISET,IPSTS, XZ,NSTSXZ) PARAMETER (MXPKS = 150, MXHEAV=20,MXSTSP=140) PARAMETER (MXSTSX=30, IXZ=5*MXHEAV+5) DIMENSION XP2(5, MXPKS), NCOSTA(MXHEAV), PISET(MXHEAV+3,MXSTSP) DIMENSION MULORD(MXPKS), ICANPK(MXPKS), PISET1(MXHEAV+3,MXSTSP), * ICANP1(MXPKS), XZ(IXZ,MXSTSX) PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV), * IBRK, ICD, MINBRK 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)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) DATA NPI1 /0/ NPKS=NPCT CALL SELCPK(XP2,NPKS, ICANP1) MINBRK=NCONS1+1 IF (MINBRK.GT.NCONS) MINBRK=1 IF (P1METH .AND. MINBRK.EQ.1 .AND. NCONS.GE.2) MINBRK=2 ICP=-1 IF (MINBRK.EQ.1 .OR. (P1METH.AND.MINBRK.EQ.2)) ICP=0 IF (ICP.LT.0 .AND. MINBRK.EQ.2) ICP=1 IF (ICP.LT.0 .AND. P1METH.AND.MINBRK.EQ.3) ICP=2 IF (ICP.LT.0) ICP=3 NET=0 NT1=0 DO 101 L=1,LTHV DO 100 N=1,NPKS IF (ICANP1(N).NE.L) GOTO 100 NET=NET+1 NSET(NET)=N 100 CONTINUE IF ((ICP.EQ.1 .OR. ICP.EQ.2) .AND. L.EQ.LT1) NT1=NET 101 CONTINUE WRITE(LIS1,FMT='(I4,'' peaks selected for atoms search'')') NET WRITE(LIS2,FMT='(I4,'' peaks selected for atoms search'')') NET IF (ICP.EQ.0) THEN IPSTS=0 CALL CONSPN (XP2,NPKS,MULORD,ICANP1,PISET,IPSTS) GOTO 1000 ENDIF N1=0 IF (ICP.EQ.3) THEN IF (NPI1.EQ.0) THEN VALXZM=XZ(5*MXHEAV+3,1) DO 110 N=1,NSTSXZ IF (XZ(5*MXHEAV+3,N)/VALXZM .LT. 0.666) GOTO 112 NN=XZ(5*MXHEAV+5,N) IF (PISET(MXHEAV,NN).LT.-0.1) THEN PISET(MXHEAV,NN)=1.0 NPI1=NPI1+1 DO 105 I=1,MINBRK-1 105 PISET1(I,NPI1)=PISET(I,NN) ENDIF 110 CONTINUE ENDIF 112 N1=NPI1 ENDIF IF (ICP.EQ.1) N1=NT1 IF (ICP.EQ.2) N1=NT1-1 IPSTS=0 DO 510 N=1,N1 IF (ICP.EQ.3) THEN DO 220 I=1,MINBRK-1 NSET1=NINT(PISET1(I,N)) DO 210 J=I,NET IF (NSET1.NE.NSET(J)) GOTO 210 NSET(J)=NSET(I) NSET(I)=NSET1 GOTO 220 210 CONTINUE GOTO 510 220 CONTINUE ELSE IF (N.GT.1) THEN NSET1=NSET(MINBRK-1) DO 310 J=MINBRK,NET 310 NSET(J-1)=NSET(J) NSET(NET)=NSET1 IF (ICP.EQ.2) THEN NP2=NSET(MINBRK-1) IF (NINT(XP2(5, NSET1)) .EQ. NINT(XP2(5, NP2)) ) GOTO 510 ENDIF ENDIF DO 410 I=1,NET I1=NSET(I) ICANPK(I1)=ICANP1(I1) IF (I.GE.MINBRK .AND. ICANPK(I1).LE.LT1) ICANPK(I1)=LT1+1 410 CONTINUE CALL CONSPN(XP2,NPKS,MULORD,ICANPK, PISET,IPSTS) 510 CONTINUE 1000 CONTINUE NCOSTA(NCONS) = 2 RETURN END SUBROUTINE CROS2P( XP2,NP, PLIM0, MULORD,NPKS, MAHEAV) PARAMETER (MXPKS = 150) DIMENSION XP2(5, MXPKS), MULORD(MXPKS) PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) 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 (KEYS(7),ITPL) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) DIMENSION XPNPEQ(3,48), XOUT(5,20), CVEC(3) LOGICAL PATSYM, TLATTI, ENANTI DATA PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE./ CALL KERNZA( PATAD, P1X2, NMAXP2) IF (P1METH) THEN NPCT=NP NPKS=NP MAHEAV=HEAVYN CALL KERNZI (1,MULORD,MXPKS) NMULN=1 NMULN2=1 NOUT=1 DO 120 N2=1,NPKS DO 110 N =N2+1,NPKS CALL VMINV(XP2(1,N2),XP2(1,N),CVEC,3) CALL GRDOUT (CVEC,FUNF) XOUT(4,1)=FUNF IF (N2.EQ.1) XP2(4,N)=FUNF CALL WRCROS (N,NMULN,N2,NMULN2,XOUT, NOUT,P1X2,NMAXP2,NPCT) 110 CONTINUE FUNF=XP2(4,N2) N=N2 CALL AR2SYM( FUNF,N,N2, NPKS, P1X2, NMAXP2) 120 CONTINUE GOTO 3000 ENDIF CALL CROSPP (XP2,NP, MULORD,PLIM0) NPKS = NPCT MAHEAV = MXESUM (XP2, NPKS, HEAVYN) IF (MAHEAV .EQ. 1) RETURN DO 2000 N2 = 1, NPKS IF (XP2(5,N2)-0.01 .GT. HEAVYN) GOTO 2000 IF (MULORD(N2) .LT. 0) GOTO 2000 NMULN2 = MULORD(N2) DO 1000 N = N2+1, NPKS IF (XP2(5,N2)+XP2(5,N)-0.01 .GT. HEAVYN) GOTO 1000 IF (MULORD(N) .LT. 0) GOTO 1000 NMULN = MULORD(N) CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP) NOUT = MAX0( NMULN2, NMULN) PXX2 = OCMINF (XP2(1,N2), XPNPEQ, NEQPNP, 1, 0, ENANTI, * PLIM0, XOUT, NOUT) IF (NOUT.EQ.0) THEN XOUT(4,1)=PXX2 NOUT=1 ENDIF CALL WRCROS (N,NMULN, N2,NMULN2, XOUT, NOUT, P1X2, NMAXP2, NPCT) 1000 CONTINUE 2000 CONTINUE 3000 CONTINUE IP2LST=IPOIN1(NPCT,NPCT,NPCT) AVCROS=0.0 DO 3100 I=1,IP2LST 3100 AVCROS=AVCROS+P1X2(I) AVCROS=AVCROS/IP2LST WRITE(LIS1,FMT='('' Average value of cross-table:'',F8.1)')AVCROS WRITE(LIS2,FMT='('' Average value of cross-table:'',F8.1)')AVCROS RETURN END SUBROUTINE CROSPP (XP2,NPKS, MULORD,PLIM0) PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 ) DIMENSION XP2(5, MXPKS), MULORD(MXPKS) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) PARAMETER (MXHEAV=20) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) DIMENSION INP1X1(MXPKS), PNXN(2), P1X1N(2,MXPKS), IP11SQ(MXPKS), * MULPK(MXPKS), P1X1(MXPKS) DIMENSION XPNPEQ(3,48), XOUT(5,20), PXX(5,20) EQUIVALENCE (XOUT(1,1), PXX(1,1)) LOGICAL PATSYM, TLATTI, ENANTI DATA PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE. / NPKSMX=MXPKS NPKSL = MIN0 (NPKS, NPKSMX) PLIML =AMAX1 (XP2(4,NPKSL),PLIM0) F = 0.5 PLIM2 = PLIML + (PLIML-PATAD)*F NPKS11 = 0 DO 1000 N = 1, NPKSL MULPK(N) = 0 PNXN(1) = N PNXN(2) = XP2(4,N) CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ) IF (XP2(4,N).GT.PLIM2 .AND. 2.0*XP2(5,N)-0.01.LT.HEAVYN) THEN NOUT = NINT( (XP2(4,N)-PLIML)/((PLIML-PATAD)*F) ) NOUT1= NINT(HEAVYN/XP2(5,N)) NOUT = MIN0(NOUT,MXHEAV-1,NOUT1) CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP) PXX2 = OCMINF * (XP2(1,N),XPNPEQ,NEQPNP, 1, 0, ENANTI, PLIML, XOUT,NOUT) PNXN(1) = N DO 110 N1 = 1, NOUT IF (XOUT(4,N1).LT.PLIM0) GOTO 1000 PNXN(2) = XOUT(4,N1) 110 CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ) ENDIF 1000 CONTINUE IPKS11=NPKS11 CALL SORTIN(IP11SQ,MXPKS, IPKS11, P1X1N, 2, NPKS11) DO 1100 M = 1, NPKS11 N = NINT(P1X1N(1,M)) MULPK(N)=MULPK(N)+1 1100 CONTINUE INP1X1(1) = 0 DO 1200 N = 1, NPKS-1 1200 INP1X1(N+1) = INP1X1(N) + MULPK(N) DO 1300 M = 1, NPKS11 N = NINT(P1X1N(1,M)) IP = INP1X1(N) + 1 P1X1(IP) = P1X1N(2,M) INP1X1(N) = IP 1300 CONTINUE NI = 0 DO 1400 N = 1, NPKSL IF (MULPK(N) .NE. 0) THEN NI = NI +1 CALL KERNAB(XP2(1,N), XP2(1,NI), 5) MULPK(NI) = MULPK(N) INP1X1(NI) = INP1X1(N) ENDIF 1400 CONTINUE NPKSL = NI NPCT=NPKS11 N1 = NPKS11+1 DO 2300 N = NPKSL,1,-1 N11 = N1 - 1 DO 2100 M = MULPK(N),1,-1 N1 = N1 - 1 MULORD(N1) = 1 - M 2100 CALL KERNAB (XP2(1,N), XP2(1,N1), 5) NMULN1 = MULPK(N) MULORD(N1) = NMULN1 NMULN2 = NMULN1 N2 = N1 NX = 0 DO 2200 NP1 = N1, N11 NX = NX + 1 2200 PXX(4,NX) = P1X1(NP1) CALL WRCROS (N1,NMULN1, N2,NMULN2, PXX, NX, P1X2, NMAXP2, NPCT) 2300 CONTINUE RETURN END SUBROUTINE HCOOUT (X, NSTSX, KATOUT) PARAMETER (MXHEAV=20, MSTSX=30) DIMENSION X(5*MXHEAV+5, MSTSX) 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 (IDDL, IFILE(1)), (IATOMS,IFILE(1)), (IATOLD,IFILE(2)) EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (IRUN, KEYS(13)) 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 DIMENSION ATXYZ(10,MXHEAV) CHARACTER*6 ATNAME(MXHEAV) CHARACTER*72 REWRCO(25) DATA NAT1 /0/ DO 100 N=1,MXHEAV CALL KERNZA (0.0, ATXYZ(1,N), 10) 100 ATXYZ(4,N)=1.0 NAT=0 NXPT = 5*MXHEAV+1 NXVL = 5*MXHEAV+3 FMUL = X(NXVL,1)/10000. FPVAL= X(NXVL,1)*0.666 IF (FMUL.LT.1.0) FMUL=1.0 IF (KATOUT .EQ. 1) * WRITE (LIS1, FMT= '(/'' Set FOM MinAv Min1 Minx '', * '' Atom x y z mult.'')') MA=0 DO 210 MX = 1, NSTSX ISETVL = NINT(X(NXVL,MX)/FMUL) AMINM = X(5*MXHEAV-1,MX) CONTHL= X(5*MXHEAV-2,MX) AMIM1 = X(5*MXHEAV-3,MX) IF (KATOUT .EQ. 1) * WRITE (LIS1,FMT='(I4,I6,3F6.3)') MX,ISETVL,AMINM, AMIM1, CONTHL NHEOUT = NINT( X(NXPT,MX)) CALL AZATNA (X(1,MX), NHEOUT, ATXYZ, ATNAME) DO 105 N=1,NHEOUT IF (KATOUT .EQ. 1) * WRITE (LIS1,FMT='(33X,A6,3F9.5,F6.2)') ATNAME(N), * (ATXYZ(I,N),I=1,4) 105 ATXYZ(4,N)=1.0 NAT = NHEOUT IF (MX .EQ. 1) REWIND IATOMS WRITE(CHOUT,FMT='('' Model PAT'',I3,'' FOM='',I6)') MX, ISETVL CALL ATOMWR(IATOMS, ATXYZ, ATNAME, NAT) IF (MX.EQ.1) NAT1=NAT MA=MA+1 IF (X(NXVL,MX) .LT. FPVAL) GOTO 310 210 CONTINUE 310 CONTINUE IF (KATOUT .EQ. 0) RETURN CALL COPY80( IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL FILCLO (IATOMS, 'KEEP') KPROG = 7 WRITE (CHOUT,FMT='(''RUN '',I3,'' ATOMS NAT= '',I4, * '' KPROG '', I3)') IRUN, NAT1, KPROG CALL LOGWR (IDDL) CALL FILCLO (IDDL, 'KEEP') WRITE (IPR1, FMT='('' Number of ATOM sets output: '', I3)') MA IF (MA .GT. 1) RETURN ICON = IDDL CALL FILINQ( ICON, 'CONDA', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) RETURN 400 CALL KERINA (ICON, LIT, 1, LEND) IF (LEND .NE. 0) RETURN IF (LIT(2) .NE. 'R2CALC' .OR. LIT(4) .NE. 'PATTY') GOTO 400 IR = 1 401 READ (ICON, FMT='(A72)', END=411) REWRCO(IR) IF (IR.EQ.1 .AND. REWRCO(1)(1:7).NE.'PROGRAM') GOTO 401 IR = IR + 1 GOTO 401 411 REWIND ICON WRITE (ICON, 430) CCODE, (ITIME(IT), IT=1,3) 430 FORMAT ('CONDA ', A6, 1X, I4, 2I3) IF (TITLE .NE. ' ') WRITE (ICON, FMT='(''TITLE '', A64)') TITLE IRL = IR - 1 DO 437 IR = 1, IRL 437 WRITE (ICON, FMT='(A72)') REWRCO(IR) CALL FILCLO (ICON, 'KEEP') IDDS = ICON CALL FILINQ( IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IDDS, FMT='(''DDMAIN''/''PHASEX''/''DDMAIN''/''FOUR'')') WRITE (IDDS, FMT='(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') RETURN END SUBROUTINE AZATNA (X, N, ATXYZ, ATNAME) DIMENSION X(5,N), ATXYZ(10,N) CHARACTER*6 ATNAME(N) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /ELEMB/ ACELTY(10) CHARACTER*2 ACELTY CHARACTER*4 CNANR M=0 DO 210 NE=1,NELMS DO 110 N1=1,N IZN1 = NINT(X(5,N1)) IF ( IZN1 .EQ. NCELLZ(NE) ) THEN M=M+1 IL = INDEX(ACELTY(NE), ' ') IF (IL.NE.2) IL=3 ATNAME(M)(1:IL-1) = ACELTY(NE)(1:IL-1) NANR=1 DO 105 NA=1,N1-1 IF (IZN1 .EQ. NINT(X(5,NA))) NANR=NANR+1 105 CONTINUE WRITE (CNANR, FMT='(I4)') NANR IN=0 111 IN=IN+1 IF (CNANR(IN:IN) .EQ. ' ') GOTO 111 ATNAME(M)(IL:) = CNANR(IN:) DO 120 I=1,4 120 ATXYZ(I,M)=X(I,N1) ENDIF 110 CONTINUE 210 CONTINUE RETURN END SUBROUTINE EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY) PARAMETER (MXHEAV=20, MXSTSX=30) DIMENSION XZ(5*MXHEAV+5,MXSTSX), NCOSTA(MXHEAV) LOGICAL READY 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) EQUIVALENCE (FRACIN, KEYS(25)) 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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) LOGICAL FIRST DATA FIRST, FRAC, LTFRA /.TRUE., 0.2, 0/ IF (FIRST) THEN FIRST=.FALSE. FRAC=FRACIN LTFRA=0 NCONS=0 I1=2 IF (NSYMM*ICENT.EQ.1) I1=3 DO 102 I=MXHEAV,I1,-1 IF (NCOSTA(I).EQ.1) THEN DO 101 J=I1,I 101 NCOSTA(J)=1 GOTO 103 ENDIF 102 CONTINUE 103 IF (P1METH .AND. NSYMM*ICENT.NE.1) THEN DO 106 J=1,3 IF (ABS(TSYMM(J,2)).GT.0.1) THEN DO 105 I=1,MXHEAV,2 105 IF (NCOSTA(I).EQ.1) NCOSTA(I)=-1 GOTO 107 ENDIF 106 CONTINUE ENDIF 107 MXHVY=0 DO 110 I=1,MXHEAV 110 IF (NCOSTA(I).EQ.1) MXHVY=I IF (MXHVY .LE. 1) THEN NCONS=1 NCONST(1)=1 LTHV=1 READY=.TRUE. GOTO 1000 ENDIF NCONS1=0 LT1=0 NHVY=MIN0(NASYMP(1), MXHVY) DO 120 I=2,LTHEAV IF ((0.6*NCELLZ(I-1)**2 .GT. NCELLZ(I)**2)) THEN LT1=I-1 GOTO 121 ENDIF NHVY=MIN0(NHVY+NASYMP(I), MXHVY) IF (NHVY.EQ.MXHVY) GOTO 122 120 CONTINUE IF (.NOT.P1METH) GOTO 122 NHVY=1 LT1=1 121 NCONS1=NHVY IF (NHVY.EQ.1) NHVY=MIN0(NHEAVY, MXHVY) IF (P1METH .AND. NHVY.EQ.2) NHVY=MIN0(NHEAVY, MXHVY) 122 CONTINUE IF (NHVY.LT.2) NHVY=2 L=0 DO 140 I=NHVY,2,-1 IF (NCOSTA(I).EQ.1) THEN NCONS = I L=1 NCONST(1)=0 DO 130 J=1,NCONS NCONST(L)=NCONST(L)+1 IF (J.EQ.NCONS) GOTO 130 IF (NCONST(L).EQ.NASYMP(L) .AND. L.LT.LTHEAV) THEN L=L+1 NCONST(L)=0 ENDIF 130 CONTINUE IF (NCONS.LT.NHVY .AND. NCONS1.GT.NCONS) THEN NCONS1=NCONS LT1=L ENDIF GOTO 141 ENDIF 140 CONTINUE 141 LTHV=L READY=.FALSE. NCOSTA(NCONS)=0 GOTO 1000 ELSE IF (NEWXZ.EQ.0) THEN DO 210 J = NCONS,MXHEAV IF (NCOSTA(J).NE.2) NCOSTA(J)=-1 210 CONTINUE ENDIF READY = .FALSE. MXCDON=0 MAXC=1 MINC=MXHEAV+1 DO 340 J = MXHEAV,1,-1 IF (NCOSTA(J).EQ.2 .AND. MXCDON.EQ.0) MXCDON=J IF (NCOSTA(J).EQ.1 .AND. MAXC.EQ.1) MAXC=J IF (NCOSTA(J).EQ.1) MINC=J IF (MAXC.NE.1.AND.(NCOSTA(J).EQ.2 .OR. MAXC.LT.MXCDON)) GOTO 400 340 CONTINUE IF (MAXC.EQ.1) NCONS=1 IF (MAXC.EQ.1) MINC=1 ENDIF 400 VALMOX=0.0 IF (NSTSXZ.GT.0) VALMOX = XZ(5*MXHEAV+3,1) IF (NSTSXZ.GT.0 .AND. NCONS.EQ.1) THEN VALMXN=IMULT**2 * NCELLZ(1)**2 * AMI2 IF (VALMXN.LT.VALMOX) THEN NCONS=2 READY=.TRUE. GOTO 1000 ENDIF ENDIF IF (READY) RETURN NCONS=0 L=1 NCONST(1)=0 DO 430 J=1,MAXC NCONS=NCONS+1 NCONST(L)=NCONST(L)+1 IF (J.EQ.MAXC) GOTO 430 IF (NCONST(L).EQ.NASYMP(L)) THEN IF (L.EQ.LTHEAV) GOTO 410 IF (J.LT.MINC .OR. NCONST(L+1)+NASYMP(L+1).LE.MAXC) THEN L=L+1 NCONST(L)=0 GOTO 430 ENDIF 410 IF (J.LT.MINC) GOTO 430 411 IF (NCOSTA(NCONS).EQ.1) GOTO 441 NCONS=NCONS-1 IF (NCONST(L).EQ.0) L=L-1 NCONST(L)=NCONST(L)-1 GOTO 411 ENDIF 430 CONTINUE 441 LTHV=L NCOSTA(NCONS)=0 IF (NCONS.EQ.1) READY=.TRUE. IF (NCONS.EQ.1) RETURN IF (MXCDON.GT.NCONS) THEN IF (NSTSXZ.EQ.0) GOTO 1000 IF (NCONS .GT. XZ(5*MXHEAV+1,1)) GOTO 1000 IMULTP=IMULT IF (P1METH) IMULTP=NLATT NHVYCL=NINT(HEAVYN*IMULTP) SUMINW=0.0 JMSUM=0 DO 520 M=1,LTHV JM=NCONST(M)*IMULTP IF (JMSUM+JM .GT. NHVYCL) JM=NHVYCL-JMSUM JMSUM=JMSUM+JM SUM=0.0 JNSUM=0 DO 510 N=1,LTHV JN=NCONST(N)*IMULTP IF (JNSUM+JN .GT. NHVYCL) JN=NHVYCL-JNSUM JNSUM=JNSUM+JN 510 SUM=SUM + JN * NCELLZ(M)*NCELLZ(N) SUMINW=SUMINW + JM*SUM 520 CONTINUE VALMX1=VALMOX IF (XZ(5*MXHEAV+1,1)+0.1 .LT. MXHEAV) * VALMX1 = (VALMOX/ XZ(5*MXHEAV-1,1)) * XZ(5*MXHEAV-3,1) FRACIN=AMAX1(0.667*VALMX1/SUMINW, FRAC) IF (FRACIN.GT. 1.2) FRACIN=1.2 VALMXN=SUMINW*AMI2 IF (VALMXN .LT. VALMOX) READY=.TRUE. ENDIF 1000 CONTINUE IF (LTHV.GT.LTFRA) THEN LTFRA=LTHV IF (NCONS.LE.1) RETURN IFPL = 1000 IF (P1METH) IFPL = 2000 1111 CALL FRALIM(FRACIN, FRACIN+0.4, IFPL, FRACN) IF (FRACIN.GT.0.29 .AND. FRACN.LT.0.001) THEN FRACIN=FRACIN-0.1 GOTO 1111 ENDIF IF (FRACN.GT.0.001) FRACIN = FRACN FRAC=FRACIN ENDIF RETURN END SUBROUTINE POS1S (XP,NP, X, NSETSX) PARAMETER (MXHEAV=20, MXSTSX=30, IX=4*MXHEAV+5,MXPKS=150) PARAMETER (MXINX=MXSTSX) DIMENSION X(IX,MXSTSX), XP(5, MXPKS) DIMENSION XF(IX), INX(MXINX) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) LOGICAL ENUGHA PARAMETER (PMAX=30254., D1=0.001) DATA XF /IX*0.0/ ENUGHA=.FALSE. NSETSX=0 ISQ = 4*MXHEAV+3 PLIML = PLIM DO 210 N = 1, NP IF (ENUGHA .AND. XP(4,N) .LT. PLIML) GOTO 220 IF (XP(5,N).LT.HEAVYN+D1) THEN ATOMSX = XP(5,N) IF (.NOT.ENUGHA) THEN ENUGHA= ATOMSX .GT. HEAVYN-D1 .OR. ATOMSX .GT. 0.99 IF (ENUGHA) THEN PLIMLL = (XP(4,N)-PATAD)*0.50 + PATAD IF (PLIMLL .LT. PLIML) PLIML=PLIMLL ENDIF ENDIF CALL KERNAB (XP(1,N), XF, 3) XF(4)=XP(5,N) XF(4*MXHEAV+1)=1. XF(4*MXHEAV+2)=ATOMSX XF(4*MXHEAV+3)=XP(4,N) + (PMAX-PLIM)*ATOMSX CALL EL2AR2 (XF,IX, ISQ, X, MXSTSX, NSETSX, INX) ENDIF 210 CONTINUE 220 CONTINUE CALL SORTIN(INX,MXINX, NSETSX, X,IX,MXSTSX) RETURN END SUBROUTINE SYMMPK (XP, NOP) PARAMETER (MXPKS=150,MXPEAK=MXPKS+100) DIMENSION XP(5, MXPEAK) 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 (LIS2, IFILE(8)) LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (MXPP=128) COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) DIMENSION ASY(6), XPP(3,12) LOGICAL PATSYM, TLATTI DATA DMAX, PATSYM, TLATTI / 0.05, .TRUE., .FALSE./ IF (.NOT. P1METH) GOTO 200 NOP=0 DO 100 N=1,NVPS CALL ALLEQP (VP(1,N), XPP, 12, PATSYM,TLATTI, NEQP) DO 95 I=1,NEQP NOP=NOP+1 CALL KERNAB(XPP(1,I),XP(1,NOP),3) XP(4,NOP)=VP(4,N) XP(5,NOP)=N+0.01 95 CONTINUE IF (N.EQ.NVPS .OR. NOP+NEQP.GT.MXPEAK) * CALL DELIPO (XP, NOP, DMAX) IF (NOP+NEQP .GT. MXPEAK) RETURN 100 CONTINUE RETURN 200 CALL ASYMS (ASY) CALL SYSTOP (ASY) CALL HAMAWT WRITE (LIS2, FMT='(/'' Subroutine HAMAWT'', * '' = symmetry of symmetry map:'' / * '' Rotation matrix Translation weight NSDH'' * , 48(/ 3(3I2, 1X), 2X, 3F6.2, F7.1, 5X, 4I4 ) )') * ( ((IRSY1(I,J,N),I=1,3), J=1,3), (TSY1(I,N), I=1,3), * SWGT(N), (NSDH(I,N), I=1,4), N=1, NSSY ) CHOUT = ' Calculate symmetry map' CALL SHOUT CALL SYMMAP CHOUT = ' ---------------------- and interpret its peaks' CALL SHOUT NPEAKS=MXPEAK CALL PEAKHG (NPEAKS, PLIM, NOP, XP) IF (NOP.GT.1) CALL DELPKO (XP, NOP, NXYZS) RETURN END SUBROUTINE SYSTOP (ASY) DIMENSION ASY(6) PARAMETER (NUMTAB =300000) COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(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 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) 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 / / ITAB(NUMTAB) INTEGER * 2 ITAB DATA IFUNMX /30254/ MLEFT = NUMTAB - NUMXYZ RES2P = 2. 101 IF (RES2P .LT. 0.9) CALL KERROR ('Symmetry map storage problems:', * 101, 'SYSTOP') DO 110 I=1,3 NXYZS(I) = NINT( RES2P * NXYZ(I)) GTXYZS(I) = FLOAT(NXYZS(I)) FSTPSY(I) = 1./GTXYZS(I) I2 = I+I ISS(I) = INT(ASY(I2-1)* GTXYZS(I) - 0.999 ) - 2 LXYZS(I) = INT(ASY(I2) * GTXYZS(I) + 0.999 ) + 2 NUMS(I) = LXYZS(I) - ISS(I) + 1 110 CONTINUE NUSXY = NUMS(1)*NUMS(2) NUSXYZ= NUSXY * NUMS(3) IF (NUSXYZ .GT. MLEFT) THEN RES2P = RES2P - 0.1 GOTO 101 ENDIF WRITE (LIS2,FMT='(/'' Subroutine SYSTOP''/ * '' Stepsizes of patterson: '',3F5.2, * '' (Angstrom)'')') (CELL(I)/GTXYZ(I), I=1,3) WRITE (LIS2,FMT='( '' Stepsizes of symmetry-map:'',3F5.2, * '' (Angstrom)'')') (CELL(I)/GTXYZS(I),I=1,3) IADEOP = NUM(1) * NUM(2) * NUM(3) NUMSC = NUSXY * ISS(3) + NUMS(1) * ISS(2) + ISS(1) - 1 - IADEOP WRITE (LIS2,FMT='( '' Stored block: NGRID / cell edges :'', 3I4, * / '' Stored block starting grid points:'', 3I4, * / '' Stored block: nr of points stored:'', 3I4 * )') NXYZS, ISS, NUMS WRITE (LIS2,FMT='( '' Address for symmetry-map: IADR ='', I7, * '' * IZ +'', I3, '' * IY + IX -'', I7)') NUSXY, NUMS(1), NUMSC IADR1 = IADEOP + 1 IADEND= IADEOP + NUMS(1)*NUMS(2)*NUMS(3) DO 210 IADR = IADR1, IADEND 210 ITAB(IADR) = IFUNMX RETURN END SUBROUTINE SYMMAP 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 /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) DIMENSION NUMSS1(3), IX(3), X(3),GX(3) DATA FUNMX /30254./ FUNFSP = FUNMX + 1. SYMAX = 30254. DO 500 NSY1= 2, NSSY DO 104 I=1,3 IF (IRSY1(1,I,NSY1).EQ.0 .AND. IRSY1(2,I,NSY1).EQ.0 .AND. * IRSY1(3,I,NSY1).EQ.0) THEN NUMSS1(I) = 1 ELSE NUMSS1(I) = NUMS(I) ENDIF 104 CONTINUE NUMXS1=NUMSS1(1) NUMYS1=NUMSS1(2) NUMZS1=NUMSS1(3) SYMXNW= 0.0 GX(3) = ISS(3) - 1 IX(3) = ISS(3) - 1 DO 333 JZ = 1, NUMZS1 IX(3) = IX(3)+1 GX(3) = GX(3)+1. X(3) = GX(3)/GTXYZS(3) GX(2) = ISS(2) - 1 IX(2) = ISS(2) - 1 DO 222 JY = 1, NUMYS1 IX(2) = IX(2)+1 GX(2) = GX(2)+1. X(2) = GX(2)/GTXYZS(2) GX(1) = ISS(1) - 1 IX(1) = ISS(1) - 1 DO 111 JX = 1, NUMXS1 IX(1) = IX(1)+1 GX(1) = GX(1)+1. X(1) = GX(1)/GTXYZS(1) CALL STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW) 111 CONTINUE 222 CONTINUE 333 CONTINUE SYMAX=SYMXNW 500 CONTINUE RETURN END SUBROUTINE HAMADI(IRSY1, NUMS, NUMXS1) DIMENSION IRSY1(3,3), NUMS(3), NUMXS1(3) DO 140 I=1,3 IF (IRSY1(1,I).EQ.0 .AND. IRSY1(2,I).EQ.0 * .AND. IRSY1(3,I).EQ.0) THEN NUMXS1(I) = 1 ELSE NUMXS1(I) = NUMS(I) ENDIF 140 CONTINUE RETURN END SUBROUTINE HARVEC (IRSY1, TSY1, X, XS) DIMENSION IRSY1(3,3), TSY1(3), X(3), XS(3) DO 120 I2 = 1,3 XS(I2) = 0. DO 110 I1 = 1,3 IF (IRSY1(I2,I1) .NE. 0) THEN IF (IRSY1(I2,I1) .GT. 0) THEN XS(I2) = XS(I2) + X(I1) IF (IRSY1(I2,I1) .EQ. 2) XS(I2) = XS(I2) + X(I1) ELSE XS(I2) = XS(I2) - X(I1) ENDIF ENDIF 110 CONTINUE 120 CONTINUE CALL VPLUSV (XS, TSY1, XS, 3) RETURN END SUBROUTINE STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW) DIMENSION X(3),IX(3), NUMSS1(3) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION XGS(3),XG(3),STPX(3) LOGICAL FIRST1 DATA FUNF /30254./ FIRST1=.TRUE. DO 101 I=1,3 XGS(I)= IX(I)/GTXYZS(I) 101 STPX(I)=1./GTXYZS(I) IXL1= IX(1) IYL1= IX(2) IZL = IX(3) XG(3)=XGS(3) DO 333 JZ = NUMSS1(3), NUMS(3) IYL = IYL1 XG(2)= XGS(2) DO 222 JY = NUMSS1(2), NUMS(2) IXL = IXL1 XG(1)= XGS(1) DO 111 JX = NUMSS1(1), NUMS(1) IADR = NUSXY * IZL + NUMS(1) * IYL + IXL - NUMSC IJX = ITAB(IADR) FUNF1 = FLOAT( IJX ) / 99. IF (FIRST1) THEN FUNF=SSMINF(X,NSY1,.FALSE.,NSMIN) KG=1 CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF) IF (WFUNF .GT. SYMAX-.1) RETURN FIRST1=.FALSE. ENDIF KG=0 CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF) IFUNF = NINT(WFUNF * 100.) IF (IFUNF .LT. 0) IFUNF = 0 IF (WFUNF .LT. FUNF1) THEN ITAB(IADR) = IFUNF IF (SYMXNW.LT.WFUNF) SYMXNW = WFUNF ENDIF IXL = IXL + 1 XG(1) = XG(1)+STPX(1) 111 CONTINUE IYL = IYL + 1 XG(2) = XG(2)+STPX(2) 222 CONTINUE IZL = IZL + 1 XG(3) = XG(3)+STPX(3) 333 CONTINUE RETURN END SUBROUTINE HAVWGT (NSY1, X, KG, FUNF, WFUNF) DIMENSION X(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) COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) DIMENSION XQ1(3,5), XQL(3), XDUMMY(3) LOGICAL FIRST DATA FIRST,ITS,NLT,DMAX /.TRUE.,1,0, 0.3/ WGTV = SWGT(NSY1) WFUNF=FUNF IF (WGTV.LT.1.1) RETURN IF (KG.EQ.1) GOTO 300 N1=1 CALL KERNAB(X,XQ1(1,1),3) NDH=NINT(WGTV) DO 120 N = 1,NDH-1 NSS=NSDH(N,NSY1) INVERT=1 IF (NSS.LT.0) INVERT=-1 NSS=IABS(NSS) N1=N1+1 CALL SYMEQU(NSS,ITS,NLT,INVERT,FIRST,X,XQ1(1,N1),XDUMMY) DO 120 NT=1,NLATT CALL VPLUSV (XQ1(1,N1),TLATT(1,NT),XQL,3) DO 110 N2=1,N1-1 IF (ISELFD(XQ1(1,N2),XQL,DMAX).EQ.1) THEN WGTV=WGTV-1. IF (WGTV .LT. 1.1) RETURN N1=N1-1 GOTO 210 ENDIF 110 CONTINUE 120 CONTINUE 210 CONTINUE 300 WGTV = (WGTV-1.)*0.5 + 1. WFUNF=(WFUNF-PATAD)/WGTV + PATAD RETURN END SUBROUTINE DELPKO (XP, NP, NXYZ) DIMENSION XP(5,NP), NXYZ(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) COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) LOGICAL ENANTI DATA ENANTI /.TRUE./ DMAX=SQRT( (CELL(1)/NXYZ(1))**2 + * (CELL(2)/NXYZ(2))**2 + * (CELL(3)/NXYZ(3))**2 ) CALL DELXEQ (XP, NP, NOR, .FALSE., ENANTI, DMAX) RETURN END SUBROUTINE WRCROS (N,NMULN, N2,NMULN2, XNO,NX, P1X2, NMAXP2, NPKS) DIMENSION XNO(5,20),P1X2(NMAXP2) DO 2200 J = 0, NMULN-1 M = N + J DO 1100 K = 0, NMULN2-1 M2= N2+ K IF (K.EQ.J) THEN PXX2 = XNO(4,1) ELSE IF (K.GT.0 .AND. J.GT.0) THEN PXX2 = XNO(4,2) ELSEIF (K.EQ.0) THEN IF (J.LT.NX) THEN PXX2 = XNO(4,J+1) ELSE PXX2 = 0.0 ENDIF ELSE IF (J.EQ.0) THEN IF (K.LT.NX) THEN PXX2 = XNO(4,K+1) ELSE PXX2 = 0.0 ENDIF ENDIF CALL AR2SYM( PXX2,M,M2, NPKS, P1X2, NMAXP2) 1100 CONTINUE 2200 CONTINUE RETURN END SUBROUTINE CONSPN(XP,NPKS,MULORD,ICANPK, PISET,NSTS) PARAMETER (MXHEAV=20,MXSTSP=140, MXHEV2=MXHEAV+3) DIMENSION XP(5, NPKS),MULORD(NPKS), ICANPK(NPKS), * PISET(MXHEV2,MXSTSP) 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV), * IBRK, ICD, MINBRK DIMENSION QPSET(MXHEV2), INP2S(MXSTSP), CVEC(3), VEC23(3) LOGICAL COOK, FSTCOM PARAMETER (PMAX = 30254.) DATA QPSET, DMAX /MXHEV2*0.0, 0.35 / IF (NCONS1.EQ.NCONS) THEN QPSET(MXHEAV)=-1.0 ELSE QPSET(MXHEAV)= 1.0 ENDIF IF (MINBRK.LE.0 .OR. MINBRK.GT.NCONS) MINBRK=1 QPSET(MXHEV2)=MINBRK-1 HEVYN1 = HEAVYN+0.01 NDIM1 = MXHEV2 NATM= MXHEAV + 1 ISQ = MXHEAV + 2 NH = NCONS IF (NET .LT. NH) GOTO 2000 NEP = NH NLVP1 =NSET(2) IBRK=1 IEL(1)=0 FSTCOM=.TRUE. NUPS=0 1111 CALL UPSETX IF (NUPS.LT.100) THEN NUPS=NUPS+1 IF (NUPS.EQ.50) THEN ENDIF ELSE IF (NUPS.EQ.100) THEN NUPS=NUPS+1 ENDIF IF (.NOT.FSTCOM .AND. IBRK.LT.MINBRK) GOTO 2000 FSTCOM=.FALSE. IF (P1METH .AND. IBRK.EQ.2) THEN N2=NLVP1 DO 250 M1=2,NPCT IF (ICANPK(M1).GT.LTHV) GOTO 250 DO 240 M2=M1+1,NPCT IF (ICANPK(M2).GT.LTHV) GOTO 240 NCR=IPOIN1(M1,M2,NPCT) IF (P1X2(NCR).GT.0.0) THEN CALL VMINV(XP(1,M1),XP(1,M2),CVEC,3) ISLF=ISELFD(CVEC,XP(1,N2),DMAX) IF(ISLF.EQ.1) P1X2(NCR)=-P1X2(NCR) ENDIF 240 CONTINUE 250 CONTINUE LVI2 = XP(5, NLVP1) NVI2 = XP(5, NPSET(2)) NLVP1=NPSET(2) IF (LVI2.EQ.NVI2) GOTO 1111 ENDIF CALL CHCKCO (ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK) IF (COOK) THEN CALL KERI2F (NPSET,QPSET,NH) QPSET(NH+1)= 0.0 QPSET(NATM)= ATMSVL QPSET(ISQ) = PSETVL+ AMIN1(ATMSVL,HEAVYN)*(PMAX-PLIM) CALL EL2AR2 (QPSET, NDIM1, ISQ, PISET,MXSTSP, NSTS, INP2S) ENDIF IF (P1METH .AND. IBRK.EQ.3) THEN N2=NPSET(2) N3=NPSET(3) CALL VMINV(XP(1,N2),XP(1,N3), VEC23, 3) DO 320 NT=1,NET NP=NSET(NT) IF (NP.LT.0) GOTO 320 IF (ISELFD(VEC23, XP(1,NP), DMAX).EQ.1) NSET(NT)=NP-ICD 320 CONTINUE ENDIF GOTO 1111 2000 CONTINUE DO 350 N=1,NET DO 340 ID=1,NEP IF (NSET(N).GT.0) GOTO 350 NSET(N)=NSET(N)+ICD 340 CONTINUE 350 CONTINUE IF(NSTS.GT.1) CALL SORTIN(INP2S,MXSTSP,NSTS, PISET,NDIM1,NSTS) IF (P1METH) THEN DO 410 M1=2,NPCT DO 410 M2=M1+1,NPCT NCR=IPOIN1(M1,M2,NPCT) IF (P1X2(NCR).LT.0.0) P1X2(NCR)=-P1X2(NCR) 410 CONTINUE ENDIF RETURN END FUNCTION TCOMBS(K,N) PARAMETER (TCOMMX=1.0E+30) TCOMBS=1.0 IF (K.GE.N) THEN IF (K.GT.N) TCOMBS=0.0 RETURN ELSE FK=K FN=N TCOMOF=TCOMMX/(FN-FK) DO 110 I=1,K TCOMBS=TCOMBS*(FN/FK) IF (TCOMBS.GT.TCOMOF) GOTO 210 FN=FN-1. FK=FK-1. 110 CONTINUE RETURN ENDIF 210 TCOMBS=-TCOMMX RETURN END FUNCTION COMBNO(IEL,K,N) DIMENSION IEL(K) PARAMETER (TCOMMX=1.0E+30) IF (K.EQ.1) THEN COMBNO=IEL(1) RETURN ENDIF J1=1 N1=0 COMBNO=0.0 DO 210 I=1,K-1 K1=K-I IF (J1.LT.IEL(I)) THEN N1=N-J1 TCO=TCOMBS(K1,N1) IF (TCO.LT.0.0 .OR. TCO.GT.TCOMMX-COMBNO) THEN COMBNO = -TCOMMX RETURN ENDIF COMBNO = COMBNO + TCO J1=J1+1 FN1K1=N1-K1 FN1=N1 111 IF (J1.LT.IEL(I)) THEN TCO=TCO*FN1K1/FN1 IF (TCO.GT.TCOMMX-COMBNO) THEN COMBNO = -TCOMMX RETURN ENDIF COMBNO = COMBNO + TCO FN1K1=FN1K1-1. FN1=FN1-1. J1=J1+1 GOTO 111 ENDIF ENDIF J1=IEL(I)+1 210 CONTINUE COMBNO=COMBNO+IEL(K)-IEL(K-1) RETURN END c heavy atomtype. SUBROUTINE CHCKCO(ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK) DIMENSION ICANPK(NPKS), MULORD(NPKS), XP(5, NPKS) LOGICAL COOK PARAMETER (MXPKS=150, MXHEAV=20) COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV), * IBRK, ICD, MINBRK COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV DIMENSION ATMSV(MXHEAV), PSETV(MXHEAV) COOK=.FALSE. IBRK1= MULSET (NPSET, NEP, MULORD, NPKS) LT=LTHV IF (IBRK1.LE.1) RETURN IBRK2= NRATY(LT,NCONST,LTHV, NPSET,IBRK1-1, ICANPK,NPKS) IF (IBRK2.EQ.IBRK) RETURN HEVYN1 = HEAVYN+0.01 IBRK3=IBRK2 DO 130 I = IBRK, IBRK2-1 II=NPSET(I) IF (I.EQ.1) THEN ATMSV(1) = AMIN1(XP(5,II),1.0) PSETV(1) = XP(4,II) ELSE ATMSV(I) = ATMSV(I-1) + AMIN1( XP(5,II), 1.0) PSETV(I) = AMIN1 (PSETV(I-1), XP(4,II)) ENDIF IF (ATMSV(I).GT.HEVYN1) THEN IBRK3=I GOTO 200 ENDIF DO 120 J = 1, I-1 JJ=NPSET(J) IJ = IPOIN1(JJ,II, NPCT) IF (P1X2(IJ) .LT. PLIM) THEN IBRK3=I GOTO 200 ENDIF IF (PSETV(I).GT.P1X2(IJ)) PSETV(I) = P1X2(IJ) 120 CONTINUE 130 CONTINUE IF (IBRK2-1 .EQ. NEP) THEN PSETVL=PSETV(NEP) ATMSVL=ATMSV(NEP) ENDIF 200 IF (IBRK3 .EQ. IBRK) RETURN NP2=IBRK3-1 CALL TSTPKS(NP2,ICANPK,NPKS, COOK) RETURN END SUBROUTINE SELCPK(XP2,NPKS, ICANPK) PARAMETER (MXPKS = 150) DIMENSION XP2(5, MXPKS), ICANPK(MXPKS) PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,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) DIMENSION ICCPK(MXPKS) ISQ=2 CALL KERNZI(0,ICANPK,NPKS) DO 330 N=1,NPKS DO 320 IT=1,LTHV IF (ICANPK(N).LE.IT .AND. XP2(4,N).GT.PLIMS(IT)) THEN ICANPK(N)=IT GOTO 330 ENDIF 320 CONTINUE ICANPK(N)=LTHV+1 330 CONTINUE NCYCLE = 0 DO 350 N=1,NPKS IT1=ICANPK(N) DO 340 IT=IT1,LTHV CALL ATYPKS(N,IT,NPKS,ICANPK,NCYCLE,ICCPK,NHT) IF (IT.EQ.NHT) THEN ICANPK(N)=IT GOTO 350 ENDIF 340 CONTINUE ICANPK(N)=LTHV+1 350 CONTINUE ITEST=0 RETURN END SUBROUTINE TSTPKS(NP2, ICANPK,NPKS, COOK) DIMENSION ICANPK(NPKS) LOGICAL COOK 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) PARAMETER (MXPKS=150, MXHEAV=20) COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV), * IBRK, ICD, MINBRK COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV DIMENSION ICCPK(MXPKS), ICAPKL(MXPKS,MXHEAV) LOGICAL OKF NCYCLE=1 IF (IBRK.EQ.1) THEN NI1=1 CALL KERNZI(LTHV+1,ICAPKL(1,1),NPKS) DO 102 NR=1,NET NO=NSET(NR) ICAPKL(NO,1)=ICANPK(NO) 102 CONTINUE ELSE NI1=IEL(IBRK-1)+1 ENDIF COOK=.FALSE. NP1=IBRK DO 210 NN=NP1,NP2 N=NPSET(NN) NI=IEL(NN) DO 104 MI=NI1,NI-1 M=NSET(MI) 104 IF (M.GT.0) ICAPKL(M,NN)=LTHV+1 OKF=.FALSE. NHT=LTHV+1 LTN=LTHV IF (P1METH .AND. NN.EQ.1) THEN LTN=1 ELSE IF (NN.LE.NCONS1 .AND. LT1.LT.LTHV) THEN LTN=LT1 ENDIF DO 150 I = LTN, ICAPKL(N,NN), -1 IF (I .GT. NHT) GOTO 150 CALL ATYPKS(N,I,NPKS,ICAPKL(1,NN),NCYCLE,ICCPK,NHT) IF (NHT.EQ.0) GOTO 160 IF (I.GT.NHT) GOTO 150 IF (NRATY(NHT,NCONST,LTHV,NPSET,NN,ICCPK,NPKS).LE.NN) GOTO 150 IF (I .GT. NHT) GOTO 150 IF (NN.EQ.NEP) THEN COOK=.TRUE. RETURN ENDIF IF (OKF) THEN ICAPKL(N,NN+1)=I ELSE OKF=.TRUE. ICAPKL(N,NN+1)=I DO 110 M=1,NPKS 110 IF (M.NE.N) ICAPKL(M,NN+1)=ICCPK(M) DO 120 NR=1,NET NO=NSET(NR) IF (NO.GT.0) THEN IF (ICAPKL(NO,NN+1) .LE. LTHV) GOTO 120 ENDIF NSET(NR)=NO-ICD 120 CONTINUE IBRK=NN+1 ENDIF 150 CONTINUE 160 IF (.NOT.OKF) RETURN NI1=NI+1 210 CONTINUE IBRK=NP2+1 RETURN END SUBROUTINE ATYPKS(N,I,NPKS,ICANPK,NCYCLE,ICCPK,NHT) DIMENSION ICANPK(NPKS),ICCPK(NPKS) PARAMETER (MXPKS = 150) DIMENSION ICCDY(MXPKS) LOGICAL CHCTYP COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV CALL TSTATY(N,I,NPKS,ICANPK, ICCPK,NHT) IF (NHT.NE.I .OR. NCONS.LT.3 .OR. NCYCLE.EQ.0) RETURN DO 310 NCY=1,NCYCLE CHCTYP = .FALSE. DO 210 M=1,NPKS IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210 J1=ICCPK(M) MHT=LTHV+1 MJ=MHT DO 110 J=LTHV,J1,-1 IF (J .GT. MHT) GOTO 110 CALL TSTATY(M,J,NPKS,ICCPK,ICCDY, MHT) IF (J.EQ.MHT) MJ=J IF (MHT.EQ.0) THEN IF (ICCPK(M) .LT. MJ) THEN CHCTYP=.TRUE. ICCPK(M)=MJ ENDIF GOTO 210 ENDIF 110 CONTINUE 210 CONTINUE IF (CHCTYP) THEN NHT = NATYOK (N,I, ICCPK,NPKS, NCONST,LTHV) IF (NHT.EQ.0) RETURN ELSE RETURN ENDIF 310 CONTINUE RETURN END SUBROUTINE TSTATY (N,I,NP, ICANPK, ICCPK, NHT) DIMENSION ICANPK(NP), ICCPK(NP) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV PARAMETER (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) CALL KERNAI (ICANPK,ICCPK,NP) DO 210 M=1,NP IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210 NM = IPOIN1(N,M,NPCT) DO 110 J=1,LTHV IF (P1X2(NM).GT.PLIMC(I,J)) THEN IF (ICCPK(M).LT.J) ICCPK(M)=J GOTO 210 ENDIF 110 CONTINUE ICCPK(M)=LTHV+1 210 CONTINUE NHT = NATYOK (N,I, ICCPK,NP, NCONST,LTHV) RETURN END FUNCTION NATYOK (N,I, ICANPK,NP, NCONST,LT) DIMENSION NCONST(LT), ICANPK(NP), NPTY(11), NCTY(11) CALL KERNZI (0, NPTY, 11) DO 110 M = 1,NP IF (M.NE.N) NPTY(ICANPK(M))=NPTY(ICANPK(M)) + 1 110 CONTINUE DO 420 II=I,ICANPK(N),-1 CALL KERNAI(NPTY,NCTY,11) NCTY(II)=NCTY(II)+1 DO 410 J=1,LT IF (NCTY(J).LT.NCONST(J)) GOTO 420 IF (J.LT.LT) THEN NCTY(J+1)=NCTY(J+1) + (NCTY(J)-NCONST(J)) NCTY(J)=NCONST(J) ENDIF 410 CONTINUE NATYOK = II RETURN 420 CONTINUE NATYOK = 0 RETURN END FUNCTION NRATY (J,NCONST,LT, IPKSET,NPS, ICANPK,NP) DIMENSION NCONST(LT), IPKSET(NPS), ICANPK(NP), NPTY(11) CALL KERNZI (0, NPTY, 11) DO 210 M = 1,NPS-1 N=IPKSET(M) I=ICANPK(N) 111 CONTINUE IF (NPTY(I).LT.NCONST(I)) THEN NPTY(I)=NPTY(I) + 1 ELSE I=I+1 IF (I.LE.LT) GOTO 111 NPTY(I-1)=NPTY(I-1)+1 NRATY=M RETURN ENDIF 210 CONTINUE N=IPKSET(NPS) J1=J DO 310 I = J1, ICANPK(N), -1 IF (NPTY(I).LT.NCONST(I)) THEN J=I NRATY=NPS+1 RETURN ENDIF 310 CONTINUE NRATY=NPS RETURN END SUBROUTINE UPSETX PARAMETER (MXPKS=150, MXHEAV=20) COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV), * IBRK, ICD, MINBRK IF (IEL(1) .EQ. 0) THEN DO 101 I = 1,NEP NPSET(I)=NSET(I) 101 IEL(I) = I IBRK=1 ICD=0 DO 102 I = 1,NET 102 IF (ICD.LT.NSET(I)) ICD=NSET(I) ICD=ICD+1 RETURN ENDIF IBRKI = IBRK DO 500 I = IBRKI,1,-1 IF (IEL(I) .NE. NET-NEP+I) THEN IF (I.LT.IBRK) THEN DO 220 N=1,NET DO 210 ID=1,IBRK-I IF (NSET(N).GT.0) GOTO 220 NSET(N)=NSET(N)+ICD 210 CONTINUE 220 CONTINUE IBRK=I ENDIF NR = IEL(I) DO 320 J=I-1, NEP-1 310 NR = NR + 1 IF (NR .LE. NET-NEP+J+1) THEN IF (NSET(NR).LT.0) GOTO 310 IEL(J+1)=NR ELSE GOTO 500 ENDIF 320 CONTINUE DO 410 J=I,NEP 410 NPSET(J)=NSET(IEL(J)) RETURN ENDIF 500 CONTINUE IEL(1)=0 IBRK=0 RETURN END FUNCTION MXESUM (X, NX, SUMMX) DIMENSION X(5,NX) PARAMETER (MXE=100) DIMENSION E(MXE) SUM = 0.0 MXESUM=0 JMAX=1 DO 510 N = 1,NX IF (MXESUM.LT.MXE) THEN MXESUM = MXESUM+1 ELSE MXESUM=-MXESUM RETURN ENDIF E(MXESUM) = X(5,N) IF (SUM+E(MXESUM).LT.SUMMX+0.0001) THEN SUM=SUM+E(MXESUM) IF (E(MXESUM).GT.E(JMAX)) JMAX=MXESUM ELSE IF (E(MXESUM).LT.E(JMAX)) THEN SUM=SUM-E(JMAX) SUM=SUM+E(MXESUM) E(JMAX)=E(MXESUM) DO 110 J=1,MXESUM-1 IF (E(J).GT.E(JMAX)) JMAX=J 110 CONTINUE ENDIF MXESUM=MXESUM-1 ENDIF 510 CONTINUE RETURN END FUNCTION MULSET (NPSET, NP, NMUL, N) DIMENSION NPSET(NP), NMUL(N) M=0 DO 1000 NN = 1, NP NPSTNN = NPSET(NN) IF (NMUL(NPSTNN) .GT. 0) THEN M = NN GOTO 1000 ELSE IF (M.NE.0) THEN IF (NPSTNN-NN+M .EQ. NPSET(M)) GOTO 1000 ENDIF MM= NN GOTO 1100 1000 CONTINUE MM = NP + 1 1100 MULSET = MM RETURN END FUNCTION SMINF (X, XS, NEQP,NXS, NXSEQX) DIMENSION X(3), XS(3,NEQP,NXS) DIMENSION VECS(3,48) DATA NV, VALMAX /48, 30254./ SMINF=VALMAX DO 120 NX = 1,NXS IF (NX .EQ. NXSEQX) GOTO 120 CALL VECXXS( X, XS(1,1,NX), NEQP, VECS, NV, NVECS) DO 110 N = 1, NVECS CALL GRDOUT(VECS(1,N), FUNF) IF (SMINF .GT. FUNF) SMINF = FUNF 110 CONTINUE 120 CONTINUE RETURN END FUNCTION SSMINF (X,NREQP, WGTING, NEMIN) DIMENSION X(3) LOGICAL WGTING 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 /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) DIMENSION VXYZ(3) DIMENSION VXYZT(3) DATA VALMAX /30254./ SSMINF=VALMAX NEMIN=0 KG=0 WGTV=1.0 IF (NREQP .GT. 1) THEN NE1= NREQP NEQP=NREQP ELSE NE1= 2 NEQP = NSSY ENDIF DO 500 NE = NE1, NEQP CALL HARVEC (IRSY1(1,1,NE), TSY1(1,NE), X, VXYZ) CALL REDFCO (VXYZ, VXYZ, 3) DO 125 NL=1,NLATT VXYZT(1)=VXYZ(1)+TLATT(1,NL) VXYZT(2)=VXYZ(2)+TLATT(2,NL) VXYZT(3)=VXYZ(3)+TLATT(3,NL) CALL REDFCO (VXYZT, VXYZT, 3) DO 120 I=1,3 IF (ABS(VXYZT(I)) .GT. 1.5*FSTPSY(I)) GOTO 125 120 CONTINUE FUNF = VALMAX GOTO 130 125 CONTINUE CALL GRDOUT (VXYZ, FUNF) IF (WGTING) THEN CALL HAVWGT (NE,X,KG,FUNF,WFUNF) FUNF=WFUNF ENDIF 130 IF (SSMINF.GT.FUNF) THEN SSMINF=FUNF NEMIN=NE ENDIF 500 CONTINUE RETURN END FUNCTION OCMINF (X,XS,NEQP, NXS, NXSEQX, ENANTI, PLIMM, XOUT,NOUT) DIMENSION X(3), XS(3,NEQP,NXS), XOUT(5,NOUT) LOGICAL ENANTI 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 /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) PARAMETER (MXHEAV=20) DIMENSION XO(3), XL(3), XOU(5), INXOUT(MXHEAV) LOGICAL ONEXT, OSTART, PEAK DATA NADDED /0/ CALL KERNAB (X,XL,3) PLIM1=PLIMM-0.1 OCMINF = 0.0 IF (NOUT .GT. 1) THEN NADDED = 0 IF (NOUT .GT. MXHEAV) NOUT = MXHEAV ENDIF ONEXT = .TRUE. IF (ENANTI .AND. ICENT.EQ.1) THEN NEN = -1 ELSE NEN = 1 ENDIF DO 310 NE = 1,NEN,-2 DO 210 NO = 1,NOR OSTART=.TRUE. 110 CALL ORSHIX( XL, ORIG(1,NO), XO, ONEXT) SMINX = SMINF (XO, XS, NEQP, NXS, NXSEQX) IF (OCMINF .LT. SMINX) THEN OCMINF = SMINX IF (NOUT.EQ.1) THEN CALL KERNAB(XO,XOU,3) XOU(4)= OCMINF IF (ICENT.EQ.2) XOU(4)= (OCMINF-PATAD)/2.00+PATAD XOU(5) = NE ENDIF ENDIF IF (NOUT .GT. 1) THEN CALL PKS1DF (XO, SMINX, PLIM1, OSTART, ONEXT, XOU,FUNXOU, PEAK) IF (PEAK) THEN XOU(4) = FUNXOU IF (ICENT.EQ.2) XOU(4)= (FUNXOU-PATAD)/2.00 +PATAD XOU(5) = NE CALL EL2AR2 (XOU,5,4, XOUT,NOUT, NADDED, INXOUT) ENDIF ENDIF IF (.NOT. ONEXT) GOTO 110 210 CONTINUE IF (NEN.EQ.-1) CALL INVAB (X,XL,3) 310 CONTINUE IF (ICENT.EQ.2) OCMINF = (OCMINF-PATAD)/2.00 + PATAD IF (NOUT.EQ.1) THEN IF (OCMINF .GT. PLIMM) THEN CALL KERNAB(XOU, XOUT(1,1), 5) ELSE NOUT = 0 ENDIF ENDIF IF (NOUT.GT.1) THEN NOUT = NADDED IF (NADDED.GT.1) * CALL SORTIN(INXOUT,MXHEAV,NADDED, XOUT,5,NOUT) ENDIF RETURN END SUBROUTINE PKS1DF (X3, FUNX3, FLIM, START, STOP, XPK,FUNPK, PEAK) DIMENSION X3(3) , XPK(5) LOGICAL START, STOP, PEAK DIMENSION X1(3), X2(3), X4(3) LOGICAL SECPNT PARAMETER (PMAX=30254., FUNMAX=PMAX) DATA FUNX1,FUNX2,FUNX4,FUNX5, SECPNT /0.,0.,0.,0.,.FALSE./ IF (START .AND. STOP) THEN START = .FALSE. PEAK = FUNX3.GT.FLIM IF (PEAK) THEN CALL KERNAB (X3,XPK,3) FUNPK=FUNX3 ENDIF RETURN ENDIF IF (START) THEN START = .FALSE. SECPNT= .TRUE. PEAK = .FALSE. FUNX1 = FUNMAX CALL KERNAB (X3,X4,3) FUNX4 = FUNX3 CALL KERNAB (X3,X2 ,3) FUNX2 = FUNX3 RETURN ENDIF PEAK = FUNX2.GT.FLIM .AND. FUNX2.GT.FUNX1 .AND. FUNX2.GE.FUNX3 IF (PEAK) THEN CALL KERNAB (X2,XPK,3) FUNPK=FUNX2 IF (STOP) RETURN ENDIF IF (STOP) THEN PEAK = FUNX3.GT.FLIM .AND. FUNX3.GT.FUNX2 .AND. FUNX3.GE.FUNX4 IF (PEAK) THEN CALL KERNAB (X3,XPK,3) FUNPK=FUNX3 RETURN ENDIF PEAK = FUNX4.GT.FLIM .AND. FUNX4.GT.FUNX3 .AND. FUNX4.GE.FUNX5 IF (PEAK) THEN CALL KERNAB (X4,XPK,3) FUNPK=FUNX4 ENDIF RETURN ENDIF IF (SECPNT) THEN FUNX5 = FUNX3 SECPNT =.FALSE. ENDIF CALL KERNAB (X2,X1 ,3) FUNX1 = FUNX2 CALL KERNAB (X3,X2 ,3) FUNX2 = FUNX3 RETURN END SUBROUTINE ORSHIX (X, ORIG, XO, ONEXT) DIMENSION X(3), ORIG(3), XO(3) LOGICAL ONEXT 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 /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) DIMENSION ORSH(3), FRSTEP(3), NGPXYZ(3) LOGICAL FIRST, STARTS DATA FIRST /.TRUE./ DATA NGPXYZ / 1,1,1 / DATA NGP / 0 / IF (FIRST) THEN FIRST = .FALSE. ONEXT = .TRUE. IF (IPOLA.NE.0) THEN DO 101 I=1,3 101 FRSTEP(I)= 1./GTXYZ(I) IF(MOD(IPOLA,2) .EQ.1 ) NGPXYZ(1)=NXYZ(1) IF(IPOLA.EQ.3 .OR. IPOLA.EQ.2 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.7) * NGPXYZ(2)=NXYZ(2) IF(IPOLA.GE.4 .AND. IPOLA.LE.7) NGPXYZ(3)=NXYZ(3) IF(IPOLA.EQ.8) THEN FRSTEP(2)=FRSTEP(1) FRSTEP(3)=FRSTEP(1) NGPXYZ(1)=NXYZ(1) NGPXYZ(2)=NXYZ(1) NGPXYZ(3)=NXYZ(1) ENDIF ENDIF ENDIF IF (IPOLA.EQ.0) THEN CALL KERNAB (ORIG, ORSH, 3) ELSE IF (IPOLA.NE.8) THEN STARTS = ONEXT IF (STARTS) NGP = 0 CALL SCAN3D (ORIG, ORSH, FRSTEP, NGPXYZ, NGP,STARTS) ONEXT = STARTS ELSE IF (ONEXT) THEN ONEXT = .FALSE. CALL KERNAB (ORIG, ORSH, 3) NGP = 0 ELSE CALL VPLUSV (ORSH, FRSTEP, ORSH, 3) NGP=NGP + 1 IF (NGP .EQ. NGPXYZ(1)) THEN ONEXT = .TRUE. ENDIF ENDIF ENDIF CALL VMINV (X, ORSH, XO, 3) RETURN END SUBROUTINE GRDOUT (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 /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 (ITPL, KEYS(7)) COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY) 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)) IF (ITPL.NE.10) THEN CALL RDOUTT(ARG, FUNF) RETURN ENDIF DO 301 J= 1, 3 RARG(J) = AMOD(ARG(J),1.0) IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0 301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0 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 CALL LINPOL(INEAR,IFAR,FM,FUNF) RETURN END SUBROUTINE LINPOL(INEAR,IFAR,FM,FUNF) DIMENSION INEAR(3),IFAR(3),FM(3) COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY) DIMENSION IXB(3),XB(3),FUN(3) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB K111 = NXY * INEAR(3)+ NX * INEAR(2) + INEAR(1) - NUMC IJX = ITAB(K111) FUN2 = FLOAT( IJX ) / 99. DO 400 I=1,3 KFAR = K111-INEAR(I)+IFAR(I) IJX = ITAB(KFAR) FUN3 = FLOAT( IJX ) / 99. FUN(I) = FUN2 + (FUN3-FUN2)*FM(I) DO 110 J=1,3 110 IXB(J)=INEAR(J) IXB(I)=INEAR(I)-IFAR(I)+INEAR(I) IF (IXB(I).LT.IS(I) .OR. IXB(I).GT.LXYZ(I)) THEN DO 120 J=1,3 XB(J)=IXB(J)/GTXYZ(J) XB(J) = AMOD(XB(J),1.0) IF (XB(J) .GE. 0.5) XB(J) = XB(J) - 1.0 120 IF (XB(J) .LT. -.5) XB(J) = XB(J) + 1.0 CALL SYMM(XB(1),XB(2),XB(3)) DO 130 J=1,3 XB(J)=XB(J)*GTXYZ(J) IXB(J)=NINT(XB(J)) IF (ABS(IXB(J)-XB(J)).GT.0.1) THEN GOTO 400 ENDIF 130 CONTINUE ENDIF KBEG = NXY*IXB(3)+NX*IXB(2)+IXB(1)-NUMC IJX = ITAB(KBEG) FUN1 = FLOAT( IJX ) / 99. FUN(I)= * FUN2+((FUN3-FUN1)*FM(I))/2.-((2.*FUN2-FUN3-FUN1)*FM(I)*FM(I))/2. 400 CONTINUE FUNF = FUN(1) + FUN(2)-FUN2 + FUN(3)-FUN2 RETURN END SUBROUTINE SCAN3D (X1, X, STEPX, NGPXYZ, NRGRIP, START) LOGICAL START DIMENSION X1(3),X(3),STEPX(3),NGPXYZ(3) DIMENSION XMAX(3) DATA LGRIP / 0 / IF (START) THEN CALL KERNAB (X1,X,3) DO 110 I=1,3 110 XMAX(I) = X1(I)+ ( (NGPXYZ(I)-1.5) * STEPX(I) ) LGRIP = NRGRIP-1 + NGPXYZ(1)*NGPXYZ(2)*NGPXYZ(3) START =.FALSE. RETURN ENDIF IF(X(1).LT.XMAX(1)) THEN X(1)= X(1)+STEPX(1) ELSE X(1)=X1(1) IF(X(2).LT.XMAX(2)) THEN X(2)= X(2)+STEPX(2) ELSE X(2)=X1(2) X(3)= X(3)+STEPX(3) ENDIF ENDIF NRGRIP = NRGRIP + 1 IF (NRGRIP .EQ. LGRIP) START = .TRUE. RETURN END SUBROUTINE VECXXS (X, XS, NEQP, VECS, NV, NVECS) DIMENSION X(3), XS(3,NEQP), VECS(3,NV) LOGICAL PATSYM,TLATTI DATA PATSYM,TLATTI /.FALSE.,.FALSE./ IF(NEQP.EQ.1) THEN CALL ALLEQP (XS, VECS, NV, PATSYM,TLATTI, NVECS) DO 110 M = 1, NVECS 110 CALL VMINV(X,VECS(1,M),VECS(1,M),3) ELSE NVECS = NEQP DO 120 M = 1, NVECS 120 CALL VMINV(X, XS(1,M), VECS(1,M),3) ENDIF RETURN END SUBROUTINE HAMAWT COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) 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 IRSYEQ(3,3),TM(3),TSM(3) DO 100 I=1,3 TSY1(I,1) = 0. DO 100 J=1,3 IRSY1(I,J,1) = 0 100 CONTINUE CALL KERNZA (1., SWGT, 48) SWGT(1) = 0. CALL KERNZI (0, NSDH, 192) INVEND=1-ICENT NSY1=0 DO 300 INV = 1,INVEND,-2 DO 200 NS=1,NSYMM NSY1=NSY1+1 IF (NSY1 .EQ. 1) GOTO 200 DO 120 I=1,3 DO 110 J=1,3 IRSY1(I,J,NSY1) = -(INV * IRSYMM(I,J,NS)) 110 CONTINUE IRSY1(I,I,NSY1) = IRSY1(I,I,NSY1) + 1 TSY1(I,NSY1) = -INV*TSYMM(I,NS) 120 CONTINUE DO 150 NP=1,NSYMM CALL IMAXMA(IRSYMM(1,1,NP),IRSY1(1,1,NSY1), IRSYEQ) DO 140 NSY=2,NSY1-1 INVNP=IMATEQ(IRSYEQ,IRSY1(1,1,NSY),3) IF (INVNP.EQ.0) GOTO 140 DO 130 I=1,3 TSYEQ= INVNP*(IRSYMM(I,1,NP)*TSY1(1,NSY1)+ * IRSYMM(I,2,NP)*TSY1(2,NSY1)+IRSYMM(I,3,NP)*TSY1(3,NSY1)) TM(I)=TSYEQ-TSY1(I,NSY) 130 CONTINUE DO 135 NT=1,NLATT DO 134 I=1,3 TMLI=TM(I)+TLATT(I,NT) TMLI=TMLI-NINT(TMLI) IF (ABS(TMLI).GT.0.01) GOTO 135 134 CONTINUE NSY1=NSY1-1 GOTO 200 135 CONTINUE 140 CONTINUE 150 CONTINUE SWGT(NSY1)=1. ND=0 DO 180 NS1=1,NSYMM DO 175 INVER1=1,INVEND,-2 IF (NS1.NE.1 .OR. INVER1.EQ.-1) THEN DO 171 INVER2=1,INVEND,-2 DO 170 NS2=1,NSYMM DO 161 I=1,3 DO 160 J=1,3 IRSYIJ=INVER1*IRSYMM(I,J,NS1) - INVER2*IRSYMM(I,J,NS2) IF (IRSYIJ .NE. IRSY1(I,J,NSY1)) GOTO 170 160 CONTINUE TSM(I)=INVER1*TSYMM(I,NS1)-INVER2*TSYMM(I,NS2) - TSY1(I,NSY1) 161 CONTINUE DO 165 NT=1,NLATT DO 164 I=1,3 TMLI=TSM(I)+TLATT(I,NT) TMLI=TMLI-NINT(TMLI) IF (ABS(TMLI).GT.0.01) GOTO 165 164 CONTINUE SWGT(NSY1) = SWGT(NSY1) +1. ND=ND+1 NSDH(ND,NSY1)=INVER1*NS1 IF (ND.EQ.4) GOTO 200 GOTO 180 165 CONTINUE 170 CONTINUE 171 CONTINUE ENDIF 175 CONTINUE 180 CONTINUE IF (ND.LT.4) NSDH(ND+1,NSY1)=0 200 CONTINUE 300 CONTINUE NSSY=NSY1 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 IMATEQ( IA, IB, N) DIMENSION IA(N,N), IB(N,N) IMATEQ = 0 INVERT=1 110 CONTINUE DO 200 J = 1, N DO 200 I = 1, N IF ( IA(I,J) .NE. INVERT*IB(I,J) ) THEN IF (INVERT.EQ.-1) RETURN INVERT=-1 GOTO 110 ENDIF 200 CONTINUE IMATEQ = INVERT RETURN END SUBROUTINE FIXONE(XP,NX, PISET,NSETS, PLIM, X,NSTSX) PARAMETER (MXHEAV=20, MXSTSX=30) DIMENSION XP(5, NX), PISET(MXHEAV+3,NSETS), PLIM(3), * X(4*MXHEAV+5,MXSTSX) 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2, * RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1) COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1, * XEO(5,MXHEAV), * NVEC, VEC(4,MXVC), NP1P2(2,MXVC), * NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW), * IMPNTS(MXHEAV), * VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX) DIMENSION INXEO(MXHEAV), X1(4,MXHEAV) CALL KERNZA (0.0, XF, 4*MXHEAV+5) IF (NSTSX .GT. MXSTSX) NSTSX=MXSTSX IF (NSTSX .LE. 0) FATSMX=0.0 MINPTS = FATSMX+0.01 IF (MINPTS.LT.2) MINPTS=2 DO 510 M=1,NSETS N=1 111 NP = PISET(N,M)+0.1 IF (NP.NE.0 .AND. N.LE.MXHEAV) THEN CALL KERNAB (XP(1,NP), XEO(1,N), 5) N=N+1 GOTO 111 ELSE N=N-1 ENDIF MAXPTS=N NPONT1=NINT(PISET(MXHEAV+3,M)) IF (P1METH) THEN NCM=NQSET(PISET(1,M),MAXPTS) VASETM=PISET(MXHEAV+2,M)+0.1 DO 115 M1=M-1,1,-1 IF (PISET(MXHEAV+2,M1).GT.VASETM) GOTO 116 IF (NCM .EQ. NQSET(PISET(1,M1),MAXPTS)) GOTO 510 115 CONTINUE 116 CALL SYSRCH(XEO,5,MAXPTS, X1, NX1) ATMS=0.0 DO 120 N1=1,NX1 120 ATMS=ATMS+X1(4,N1) IF (NINT(ATMS*NSYMM*ICENT).NE.MAXPTS) THEN PISET(MXHEAV,M)=0.0 GOTO 510 ENDIF NSTSX=NSTSX+1 DO 121 N1=1,NX1 121 CALL KERNAB (X1(1,N1), X(N1*4-3,NSTSX), 4) X(4*MXHEAV+1,NSTSX)=NX1 X(4*MXHEAV+2,NSTSX)=ATMS X(4*MXHEAV+3,NSTSX)=PISET(MXHEAV+2,M) X(4*MXHEAV+5,NSTSX)=M IF (NSTSX.EQ.MXSTSX) RETURN ELSE CALL DETSEQ( INXEO,N, XEO,5,MAXPTS, 5, 0) ATMS=0.0 DO 210 N=1,MAXPTS ATMS=ATMS+XEO(5,INXEO(N)) IF (ATMS.GT.FATSMX-0.01) THEN MINPTS=N GOTO 220 ENDIF 210 CONTINUE GOTO 510 220 NPONTS=MAXPTS IF (MINPTS.LT.2) MINPTS=2 XF(4*MXHEAV+5) = M XF(4*MXHEAV+1) = 0.0 CALL VIMAGE (PLIM, X, NSTSX) IF (XF(4*MXHEAV+1).LT.0.1) PISET(MXHEAV,M)=0.0 ENDIF 510 CONTINUE IF (P1METH) RETURN MXIN=MXSTSX IF (NSTSX.GT.0) CALL SORTIN(INX,MXIN,NSTSX, X,4*MXHEAV+5, MXSTSX) RETURN END SUBROUTINE VIMAGE(PLIM, X, NSTSX) PARAMETER (MXHEAV=20, MXSTSX=30) DIMENSION X(4*MXHEAV+5,MXSTSX), PLIM(3) PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2, * RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1) COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1, * XEO(5,MXHEAV), * NVEC, VEC(4,MXVC), NP1P2(2,MXVC), * NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW), * IMPNTS(MXHEAV), * VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX) DIMENSION XN1Q(3,48), XN2OUT(5,20) LOGICAL PATSYM, TLATTI, ENANTI DATA PATSYM,TLATTI,ENANTI /.FALSE.,.FALSE.,.TRUE./ MX2 = MXVC/((NPONTS*NPONTS - NPONTS)/2) IF (MX2 .GT. MXHEAV) MX2=MXHEAV NVEC=0 PLIMF=PLIM(3) DO 220 N1 = 1, NPONTS-1 CALL ALLEQP( XEO(1,N1), XN1Q, 48, PATSYM,TLATTI, NEQP) DO 210 N2 = N1+1, NPONTS IF(NPONT1.EQ.0) GOTO 101 IF (N2.LE.NPONT1) THEN PLIMF=PLIM(1) ELSE IF (N1.LE.NPONT1) THEN PLIMF=PLIM(2) ELSE PLIMF=PLIM(3) ENDIF 101 NOUT = MX2 PXX2 = * OCMINF (XEO(1,N2), XN1Q,NEQP, 1, 0, ENANTI,PLIMF, XN2OUT,NOUT) DO 110 K2 = 1, NOUT NVEC = NVEC + 1 CALL VMINV (XN2OUT(1,K2), XEO(1,N1), VEC(1,NVEC), 3) VEC(4,NVEC) = XN2OUT(4,K2) NP1P2(1,NVEC) = N1 IF (XN2OUT(5,K2) .GT. 0.0) THEN NP1P2(2,NVEC) = N2 ELSE NP1P2(2,NVEC) =-N2 ENDIF 110 CONTINUE 210 CONTINUE 220 CONTINUE PLIMF=PLIM(3) CALL COIMAG (PLIMF, X, NSTSX) RETURN END SUBROUTINE COIMAG(PLIM, X,NSTSX) PARAMETER (MXHEAV=20, MXSTSX=30) DIMENSION X(4*MXHEAV+5,MXSTSX) PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2, * RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1) COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1, * XEO(5,MXHEAV), * NVEC, VEC(4,MXVC), NP1P2(2,MXVC), * NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW), * IMPNTS(MXHEAV), * VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX) PARAMETER (NXFVAL=4*MXHEAV+3) DIMENSION ICOP(MXHEAV) LOGICAL RING, BRI, READY PARAMETER (PMAX=30254.) I=0 MAXI=NPONTS-1 NVIEW=0 NDELP=0 CALL SELVWP(NVIEW,NDELP, READY) IF (READY) RETURN CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI) 211 IF (I.EQ.0) THEN NDELP = NVWP RETURN ENDIF 311 NVW = ICOP(I) IMPNTS(I) = IVWP(NVW) J=IABS(IMPNTS(I)) CALL KERNAB (VECVWP(1,NVW),VECIM(1,I),3) PVECVJ = VECVWP(4,NVW) PVECJJ = XEO(4,J) CALL VECRIN (I, PVECVJ,PVECJJ, VALIM, SUMVIM, RING) IF (RING) THEN IL=I CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI) IF (I.GT.IL) GOTO 311 NP=IL+1 ELSE BRI=.TRUE. IL=I CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI) IF (I.GE.IL) GOTO 311 NP=IL ENDIF IF (NP .EQ. MAXPTS) THEN CALL VEC2FP (XEO,MAXPTS,VECIM,NVWP,IMPNTS,NP,XF,ATMS) XF(4*MXHEAV+1) = NP XF(4*MXHEAV+2) = ATMS XF(4*MXHEAV+3) = VALIM + (PMAX-PLIM) * ATMS XF(4*MXHEAV+4) = SUMVIM DO 510 NX=1,NSTSX IX=INX(NX) IF (X(NXFVAL,IX).LT. XF(NXFVAL)-0.01) GOTO 520 IF (X(NXFVAL,IX).GT. XF(NXFVAL)+0.01) GOTO 510 IF (X(NXFVAL+1,IX) .GT. SUMVIM-0.10 .AND. * X(NXFVAL+1,IX) .LT. SUMVIM+0.10) GOTO 530 IF (ABS(X(NXFVAL+1,IX)-SUMVIM).LT. 0.005*SUMVIM) GOTO 530 510 CONTINUE 520 CALL EL2AR2 (XF, 4*MXHEAV+5, NXFVAL, X,MXSTSX, NSTSX, INX) IF (FATSMX .LT. ATMS) THEN FATSMX = ATMS IF (MINPTS.LT.ATMS - 0.01) MINPTS=ATMS+0.01 ENDIF 530 CONTINUE ENDIF GOTO 211 END SUBROUTINE VEC2FP (XEO,NXEO,VECIM,NVWP, IMPNTS,NIP,XF,ATMS) DIMENSION XEO(5,NXEO), VECIM(3,NIP-1), IMPNTS(NIP-1), * XF(4,NIP) NFP = 0 ATMS = 0.0 DO 120 NP=1,NXEO IF (NP .EQ. NVWP) THEN NFP = NFP+1 CALL KERNAB( XEO(1,NVWP), XF(1,NFP), 3) XF(4,NFP)=XEO(5,NVWP) ATMS = ATMS + XF(4,NFP) GOTO 120 ENDIF DO 110 N = 1,NIP-1 IF (NP .EQ. IABS(IMPNTS(N)) ) THEN NFP = NFP+1 CALL VPLUSV( XEO(1,NVWP), VECIM(1,N), XF(1,NFP), 3) XF(4,NFP)=XEO(5,NP) ATMS = ATMS + XF(4,NFP) GOTO 120 ENDIF 110 CONTINUE 120 CONTINUE RETURN END SUBROUTINE SELVWP(NVIEW,NDELP, READY) LOGICAL READY PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2, * RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1, MXSTSX=30) COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1, * XEO(5,MXHEAV), * NVEC, VEC(4,MXVC), NP1P2(2,MXVC), * NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW), * IMPNTS(MXHEAV), * VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX) READY = .FALSE. IF (NDELP.GT.0 .AND. NDELP.LE.NPONTS) THEN NPONTS=NPONTS-1 READY = NPONTS .LT. MINPTS IF (READY) RETURN XEO(5,NDELP)= 0.0 ATMS=0.0 DO 101 N=1,MAXPTS 101 ATMS=ATMS+XEO(5,N) READY=ATMS.LT.FATSMX IF (READY) RETURN N=0 DO 100 NVE=1,NVEC IF (NP1P2(1,NVE).NE.NDELP .AND. IABS(NP1P2(2,NVE)).NE.NDELP) * THEN N=N+1 CALL KERNAB (VEC(1,NVE),VEC(1,N),4) NP1P2(1,N)=NP1P2(1,NVE) NP1P2(2,N)=NP1P2(2,NVE) ENDIF 100 CONTINUE NVEC=N ENDIF IF (NVIEW.GT.0 .AND. NVIEW.LE.NPONTS) THEN NVWP = NVIEW ELSE MINVVW = NVEC+1 DO 210 NVW = 1, NPONTS NVECVW = 0 DO 110 NVE = 1, NVEC IF (NP1P2(1,NVE) .EQ. NVW .OR. IABS(NP1P2(2,NVE)) .EQ. NVW) * NVECVW = NVECVW + 1 110 CONTINUE IF (NVECVW .EQ. 0) GOTO 210 IF (MINVVW .GT. NVECVW) THEN MINVVW = NVECVW NVWP = NVW ENDIF 210 CONTINUE ENDIF NVI = 0 IPO = 0 DO 410 IP = 1, NPONTS IF (NVWP .EQ. IP) GOTO 410 DO 310 NVE = 1, NVEC IF (NP1P2(1,NVE) .EQ. NVWP .AND. IABS(NP1P2(2,NVE)) .EQ. IP) THEN NVI=NVI+1 CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4) IVWP(NVI) = NP1P2(2,NVE) ELSE IF (NP1P2(1,NVE) .EQ. IP .AND. IABS(NP1P2(2,NVE)) .EQ. NVWP) THEN NVI=NVI+1 IF (NP1P2(2,NVE) .GT. 0) THEN CALL INVAB(VEC(1,NVE), VECVWP(1,NVI), 3) VECVWP(4,NVI)=VEC(4,NVE) IVWP(NVI) = NP1P2(1,NVE) ELSE CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4) IVWP(NVI) = -NP1P2(1,NVE) ENDIF ENDIF ENDIF 310 CONTINUE IPO = IPO + 1 IVP(IPO) = NVI 410 CONTINUE NVVW = NVI RETURN END SUBROUTINE VECRIN (NI, PVECVJ,PVECJJ, VALUIM, SUMVIM, RING) LOGICAL RING PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2, * RTMXH1=4.4, MXVW= 1.5 * MXHEAV * RTMXH1, MXSTSX=30) COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1, * XEO(5,MXHEAV), * NVEC, VEC(4,MXVC), NP1P2(2,MXVC), * NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW), * IMPNTS(MXHEAV), * VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX) DIMENSION VECJI(3), VECNVI(3), VALIMN(MXHEAV), SUMIMN(MXHEAV) LOGICAL DMAXCH PARAMETER (VALMIN=0.0) NII = NI IF (NII.EQ. 1) THEN VALUIM = AMIN1(PVECVJ,PVECJJ) SUMVIM = PVECVJ+PVECJJ SUMIMN(1)= SUMVIM VALIMN(1)= VALUIM DMAX = 0.80 DMAXCH=.TRUE. GOTO 211 ENDIF J = IMPNTS(NII) VALUIM= AMIN1(PVECVJ,PVECJJ,VALIMN(NII-1)) SUMVIM= PVECVJ+PVECJJ+SUMIMN(NII-1) DO 210 I1 = 1, NII-1 CALL VMINV (VECIM(1,I1), VECIM(1,NII), VECJI, 3) I = IMPNTS(I1) IRING = 0 VALJI = VALMIN DIS2MI = 4. DO 110 NV = 1, NVEC IS = 0 IF (NP1P2(1,NV) .EQ. I .AND. NP1P2(2,NV) .EQ. J) IS = -1 IF (NP1P2(1,NV) .EQ.-I .AND. NP1P2(2,NV) .EQ.-J) IS = 1 IF (IS .NE. 0) THEN IF (IS .EQ. 1) THEN IQUAL = ISELFD(VECJI, VEC(1,NV), DMAX) ELSE CALL INVAB (VEC(1,NV), VECNVI, 3) IQUAL = ISELFD(VECJI, VECNVI, DMAX) ENDIF IF (IQUAL .EQ. 1 .AND. VEC(4,NV) .GT. VALJI) THEN IRING = 1 VALJI = VEC(4,NV) ENDIF ENDIF 110 CONTINUE RING = IRING .EQ. 1 IF (.NOT. RING) RETURN IF (VALUIM .GT. VALJI) VALUIM = VALJI SUMVIM = SUMVIM + VALJI 210 CONTINUE VALIMN(NI) = VALUIM SUMIMN(NI) = SUMVIM 211 RING = .TRUE. RETURN END SUBROUTINE DISCRX(X, NMODX, XZ, NMODXZ, NEWXZ) PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5) PARAMETER (MXINXZ=MXSTSX) DIMENSION X(4*MXHEAV+5,MXSTSX), XZ(IXZ,MXSTSX) DIMENSION INXZ(MXINXZ), X1Z(IXZ) DATA X1Z /IXZ*0.0/ ISQ = 5*MXHEAV+3 NEWXZ=0 IF (NMODX.LE.0) RETURN IF (NMODXZ .GT. 0) THEN NHIGXZ=NMODXZ CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NMODXZ, ISQ, 0) ENDIF DO 120 M=1,NMODX NH = NINT( X(4*MXHEAV+1,M) ) DO 110 I = 1, NH 110 CALL KERNAB(X(4*I-3,M),X1Z(5*I-4),4) CALL ATIFCO(X1Z, NH,VAL1X,AMINMM,AMIM1,CONTHL,SUMIW) IF (VAL1X .LT. 0.1) GOTO 120 NEWXZ=NEWXZ+1 X1Z(5*MXHEAV+1) = NH X1Z(5*MXHEAV+2) = X(4*MXHEAV+2,M) X1Z(5*MXHEAV+4) = X(4*MXHEAV+4,M) X1Z(5*MXHEAV+5) = X(4*MXHEAV+5,M) X1Z(ISQ) = VAL1X IF (NH .LT. MXHEAV) THEN X1Z(5*MXHEAV-1) = AMINMM X1Z(5*MXHEAV-2) = CONTHL X1Z(5*MXHEAV-3) = AMIM1 X1Z(5*MXHEAV) = SUMIW ENDIF CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NMODXZ, INXZ) 120 CONTINUE CALL SORTIN(INXZ,MXINXZ, NMODXZ, XZ, 5*MXHEAV+5, MXSTSX) RETURN END SUBROUTINE ATIFCO (X, NX, VALX, AMINMM, AMIM1, CONTHL, SUMIW) DIMENSION X(5,NX) 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (MXOVRL=1800) PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4) COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP), * ASVECT(5,MAXASV),NASV LOGICAL READY, COVERF, OVTABL DIMENSION OVRLTA(MXOVRL), NOVRLT(3,MXOVRL), IZPOT(2,MXHEAV), * IZCOMB(2,MXHEAV), IZAT(MXHEAV), NZCONS(10), LCONST(10) DATA AMINM,AMINM1 / 0.0,0.0 / AMI1 = 0.3 AMI2 = 1.9 NPMAX=4*NLATT CALL VECCHL (X, NX, NPMAX, CONTHL) DO 120 M = 1,LTHV IZPOT(1,M) = -NCELLZ(M) 120 IZPOT(2,M) = NCELTY(M) NZP = LTHV IF (.NOT.P1METH .OR. (NSYMM.EQ.1 .AND. ICENT.EQ.1) ) THEN DO 121 M=1,LTHV 121 LCONST(M)=NCONST(M) ELSE DO 122 M=1,LTHV 122 LCONST(M)=(NCONST(M)+1)/2 ENDIF DO 130 N=1,NX 130 IZCOMB(2,N) = NINT(IMULT * X(4,N)) MSUM = 0 OVTABL = .FALSE. VALX = -1. SUMIW= VALX INIT= 0 1111 CALL COMBIS (IZCOMB,NX,INIT, IZPOT,NZP, COVERF, READY) IF (READY) RETURN IF (LTHV.GT.1) THEN CALL KERNZI (0, NZCONS, 10) DO 135 N=1,NX DO 134 M=1,LTHV IF (-IZCOMB(1,N).EQ.NCELLZ(M)) THEN NZCONS(M)=NZCONS(M)+1 GOTO 135 ENDIF 134 CONTINUE 135 CONTINUE DO 136 M=1,LTHV-1 IF (NZCONS(M).LT.LCONST(M)) GOTO 1111 136 CONTINUE ENDIF DO 140 N=1,NX 140 IZAT(N)=-IZCOMB(1,N) CALL INTWGT(NAXCEL,NPCELL, IZAT,N, SUMINW) IF (SUMINW*AMI2 .LT. VALX) GOTO 1111 IF (NASV.EQ.0) THEN AMINM = AMIN1(AMI2,1.0) COMVAL = AMINM * SUMINW + CONTHL*0.5*SUMINW ELSE IF (.NOT.OVTABL) THEN CALL OVLWGT(ASVECT,NASV,XCELL,NAXCEL,NPCELL,OVRLTA,NT,NOVRLT) OVTABL = .TRUE. ENDIF CALL OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT) CALL ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1) AMINM = AMINM/SCPAT * NLATT AMINM1= AMINM1/SCPAT * NLATT IF (AMINM1.GT.AMI2) AMINM1=AMI2 IF (AMINM.GT.AMI2) AMINM=AMI2 IF (AMINM.GT.AMI1) THEN AM1=AMINM AM2=0.0 IF (AM1.GT.1.3) THEN AM1=1.3 AM2=(AMINM-1.3)*0.1 ENDIF COMVAL = (AM1+AM2) * SUMINW + CONTHL*0.5*SUMINW ELSE COMVAL =-2.0 ENDIF ENDIF IF (COMVAL .GT. VALX) THEN SUMIW = SUMINW AMINMM= AMINM AMIM1 = AMINM1 VALX = COMVAL DO 150 N = 1,NX 150 X(5,N)= IZAT(N) ENDIF GOTO 1111 END SUBROUTINE VECCAP (X, NX, ASVECT, NASV, XCELL, NP, NAXCEL) PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4) DIMENSION X(5, NX), ASVECT(5,MAXASV), XCELL(3,MXNUP), * NAXCEL(MXNUP) 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 LOGICAL P1METH EQUIVALENCE (P1METH, SWITCH(27)) 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 (MXXEQ=48*3) DIMENSION XEQ(3,MXXEQ), XEQT(3) LOGICAL PATSYM, TLATTI, PATS, ENANTI DATA DMAX, PATSYM,TLATTI,PATS,ENANTI / 0.1,.FALSE.,.FALSE.,.TRUE., * .FALSE./ NASV=0 NP=0 NP1=0 DO 310 J = 1, NX CALL ALLEQP( X(1,J), XEQ, MXXEQ, PATSYM,TLATTI, NEQP) N11=0 DO 150 N =1,NEQP IF (N.EQ.1) GOTO 130 DO 120 L=1,NLATT CALL VPLUSV(XEQ(1,N),TLATT(1,L),XEQT,3) DO 110 N1=1,N11 110 IF (ISELFD(XEQT,XEQ(1,N1),DMAX) .EQ. 1) GOTO 150 120 CONTINUE 130 NP=NP+1 NAXCEL(NP)=J CALL KERNAB(XEQ(1,N),XCELL(1,NP),3) N11=N11+1 IF (N11.NE.1) CALL KERNAB(XEQ(1,N),XEQ(1,N11),3) 150 CONTINUE NEQP=N11 IF (NASV.EQ.MAXASV) GOTO 310 J1 = J N1 = 2 DO 220 K = J1, NX NASVJ=NASV+1 NV=0 DO 210 N = N1, NEQP NASV = NASV + 1 CALL VMINV ( X(1,K), XEQ(1,N), ASVECT(1,NASV), 3) IF (NASV.EQ.MAXASV) GOTO 310 210 CONTINUE IF (J.EQ.K) THEN NV=NASV-NASVJ+1 IF (NV.NE.0) * CALL DELXEQ (ASVECT(1,NASVJ), NV, 0, PATS, ENANTI, DMAX) NASV=NASVJ+NV-1 ENDIF N1 = 1 220 CONTINUE 310 CONTINUE IF (NASV.NE.0) * CALL DELXEQ (ASVECT, NASV, 0, PATS, ENANTI, DMAX) NP1=NP DO 410 N1=1,NP1 DO 410 L=2,NLATT CALL VPLUSV(XCELL(1,N1),TLATT(1,L),XEQT,3) DO 400 N=1,NP 400 IF (ISELFD(XEQT,XCELL(1,N),DMAX) .EQ. 1) GOTO 410 NP=NP+1 NAXCEL(NP)=NAXCEL(N1) CALL KERNAB(XEQT,XCELL(1,NP),3) 410 CONTINUE RETURN END SUBROUTINE INTWGT(NAXCEL,NP, IZAT,N, SUMINW) DIMENSION NAXCEL(NP), IZAT(N) SUMINW = 0.0 DO 210 N1=1,NP J1=NAXCEL(N1) DO 110 N2=1,NP J2=NAXCEL(N2) 110 SUMINW=SUMINW+IZAT(J1)*IZAT(J2) 210 CONTINUE RETURN END SUBROUTINE OVLWGT (ASVECT,NASV, XCELL,NAXCEL,NP, OVRLTA, NT, * NOVRLT) PARAMETER (MXOVRL=1800) DIMENSION ASVECT(5,NASV), XCELL(3,NP), NAXCEL(NP), * OVRLTA(MXOVRL), NOVRLT(3,MXOVRL) 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 /PROFIX/ RMAX, RMAX2, DEL, TAB(50) DIMENSION VECN(3), DVEC(3) NT=0 DO 510 N1=1,NP J1=NAXCEL(N1) DO 410 N2=1,NP IF (N1.EQ.N2) GOTO 410 CALL VMINV(XCELL(1,N1), XCELL(1,N2), VECN, 3) J2=NAXCEL(N2) DO 310 I=1,NASV CALL DISTSQ (VECN, ASVECT(1,I), RMAX, DVEC, RR2) IF (RR2 .LT. RMAX2) THEN NT=NT+1 G = RR2/DEL + 1. IG = G F = G - FLOAT(IG) OVRLTA(NT) = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F NOVRLT(1,NT)=I NOVRLT(2,NT)=J1 NOVRLT(3,NT)=J2 IF (NT .EQ. MXOVRL) RETURN ENDIF 310 CONTINUE 410 CONTINUE 510 CONTINUE RETURN END SUBROUTINE OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT) PARAMETER (MXHEAV=20, MXOVRL=1800) DIMENSION ASVECT(5,NASV), OVRLTA(MXOVRL), NOVRLT(3,MXOVRL), * IZAT(MXHEAV) DO 110 NV = 1,NASV 110 ASVECT(4,NV)=0.0 IF (NT.EQ.0) RETURN DO 120 N = 1,NT NV1= NOVRLT(1,N) J1 = NOVRLT(2,N) J2 = NOVRLT(3,N) ASVECT(4,NV1) = ASVECT(4,NV1) + OVRLTA(N)*IZAT(J1)*IZAT(J2) 120 CONTINUE RETURN END SUBROUTINE COMBIS (ICOMB,N,IN, IPOT,NP, COVERF, READY) DIMENSION ICOMB(2,N), IPOT(2,NP) LOGICAL COVERF, READY PARAMETER (MXCOM=20) LOGICAL CONOTP IF (N.GT. MXCOM) THEN COVERF = .TRUE. RETURN ELSE COVERF = .FALSE. ENDIF IF (IN .EQ. 0) THEN CALL COMBIM( ICOMB,N, IPOT,NP, 1, CONOTP) READY = CONOTP IF (.NOT. READY) IN=N RETURN ENDIF DO 530 JJ = N, 1, -1 DO 520 I= 1, NP IF (ICOMB(1,JJ).EQ.IPOT(1,I)) THEN IL=I DO 510 I1 = I+1,NP IF (IPOT(2,I1) .GE. ICOMB(2,JJ)) THEN IPOT(2,IL) = IPOT(2,IL) + ICOMB(2,JJ) ICOMB(1,JJ)= IPOT(1,I1) IPOT(2,I1) = IPOT(2,I1) - ICOMB(2,JJ) IL=I1 CALL COMBIM (ICOMB,N, IPOT,NP, JJ+1, CONOTP) IF (CONOTP) GOTO 510 READY = .FALSE. RETURN ENDIF 510 CONTINUE IPOT(2,I) = IPOT(2,I) + ICOMB(2,JJ) GOTO 530 ENDIF 520 CONTINUE 530 CONTINUE READY = .TRUE. RETURN END SUBROUTINE COMBIM (ICOMB,N, IPOT,NP, JJJ, CONOTP) DIMENSION ICOMB(2,N), IPOT(2,NP) LOGICAL CONOTP PARAMETER (MXCOM=20) DIMENSION LIP(MXCOM) IF (JJJ .GT. N) GOTO 410 I = 0 J1 = JJJ 111 CONTINUE JJ1= J1 LI = I+1 DO 310 J=JJ1,N DO 210 I=LI,NP IF (IPOT(2,I).GE.ICOMB(2,J) )THEN ICOMB(1,J) = IPOT(1,I) IPOT(2,I) = IPOT(2,I) - ICOMB(2,J) LIP(J) = I GOTO 309 ENDIF 210 CONTINUE J1=J-1 IF (J1.LT.JJJ) THEN CONOTP = .TRUE. RETURN ENDIF I = LIP(J1) IPOT(2,I) = IPOT(2,I) + ICOMB(2,J1) GOTO 111 309 LI = 1 310 CONTINUE 410 CONOTP= .FALSE. RETURN END SUBROUTINE ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1) DIMENSION ASVECT(5,NASV) PARAMETER (MAXASV=3600, MXMSUM=20) DIMENSION PW(MAXASV), IPW(MXMSUM) DATA ISQ, PNCV /1, 0.25/ MSUML = MSUM NCV = NASV DO 110 N=1,NASV IF (ASVECT(5,N).GT.0.10) THEN PW(N) = -ASVECT(5,N)/ASVECT(4,N) IF (ASVECT(4,N).LT.0.1) THEN ENDIF ELSE PW(N) = 0.0 ENDIF 110 CONTINUE IF (MSUM.EQ.0) THEN MSUM = NCV * PNCV IF (MSUM.LT.1) MSUM=1 MSUML= MIN0 (MSUM, MXMSUM, NCV) MSUM = MSUML ENDIF CALL DETSEQ(IPW, MSUML, PW, 1, NASV, ISQ, 0) AMINM=0.0 DO 120 I = 1,MSUML 120 AMINM = AMINM - PW(IPW(I)) AMINM = AMINM/MSUML AMINM1= -PW(IPW(1)) RETURN END SUBROUTINE PEAKHG( NPEAKS, PLEVEL, NO, XP) PARAMETER (MXPKS=150,MXPEAK=MXPKS+100) DIMENSION XP(5, MXPEAK) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) DIMENSION B(19), XX(3), XXMAX(5) DIMENSION INDXP(MXPEAK), ISXYZ2(3), LXYZ2(3) EQUIVALENCE (ISXYZ2(1), ISX2), (LXYZ2(1), LX2), * (ISXYZ2(2), ISY2), (LXYZ2(2), LY2), * (ISXYZ2(3), ISZ2), (LXYZ2(3), LZ2) DIMENSION STEPX(3) DATA XXMAX /5*0.0/ DO 100 I=1,3 100 STEPX(I)=1./GTXYZS(I) NPIEKS = NPEAKS IF (NPEAKS.GT.MXPEAK) NPIEKS = MXPEAK NO = 0 IZ1=ISS(3) IZ2=ISS(3)+1 IZ3=ISS(3)+2 DO 102 I = 1,3 ISXYZ2(I) = ISS(I) LXYZ2(I) = LXYZS(I) IF (ISS(I).LT.LXYZS(I)) THEN ISXYZ2(I) = ISXYZ2(I) + 1 LXYZ2(I) = LXYZ2(I) - 1 ENDIF 102 CONTINUE DO 333 IZ2= ISZ2,LZ2 IZ1= IZ2-1 IZ3= IZ2+1 DO 222 IY = ISY2,LY2 DO 111 IX = ISX2,LX2 B(10) = DKMAP (IX,IY,IZ2) IF (B(10) .LT.PLEVEL ) GO TO 111 B(1) = DKMAP (IX-1,IY-1,IZ2) IF (B(10) .LT. B(1) ) GO TO 111 B(2) = DKMAP (IX,IY-1,IZ1) IF (B(10) .LT. B(2) ) GO TO 111 B(3) = DKMAP (IX,IY-1,IZ2) IF (B(10) .LT. B(3) ) GO TO 111 B(4) = DKMAP (IX,IY-1,IZ3) IF (B(10) .LT. B(4) ) GO TO 111 IBB = NINT ( (B(10)-B(4)) * 99.) IF (IZ3.LE.LZ2 .AND. IBB.EQ.0 ) GO TO 111 B(5) = DKMAP (IX+1,IY-1,IZ2) IF (B(10) .LT. B(5) ) GO TO 111 B(6) = DKMAP (IX-1,IY,IZ1) IF (B(10) .LT. B(6) ) GO TO 111 B(7) = DKMAP (IX-1,IY,IZ2) IF (B(10) .LT. B(7) ) GO TO 111 B(8) = DKMAP (IX-1,IY,IZ3) IF (B(10) .LT. B(8) ) GO TO 111 IBB = NINT ( (B(10)-B(8)) * 99.) IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111 B(9) = DKMAP (IX,IY,IZ1) IF (B(10) .LT. B(9) ) GO TO 111 B(11) = DKMAP (IX,IY,IZ3) IF (B(10) .LT. B(11)) GO TO 111 IBB = NINT ( (B(10)-B(11)) * 99.) IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111 B(12) = DKMAP (IX+1,IY,IZ1) IF (B(10) .LT. B(12)) GO TO 111 B(13) = DKMAP (IX+1,IY,IZ2) IF (B(10) .LT. B(13)) GO TO 111 IBB = NINT ( (B(10)-B(13)) * 99.) IF (IX.LT.LX2 .AND. IBB.EQ.0) GO TO 111 B(14) = DKMAP (IX+1,IY,IZ3) IF (B(10) .LT. B(14)) GO TO 111 IBB = NINT ( (B(10)-B(14)) * 99.) IF ((IX.LT.LX2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111 B(15) = DKMAP (IX-1,IY+1,IZ2) IF (B(10) .LT. B(15)) GO TO 111 IBB = NINT ( (B(10)-B(15)) * 99.) IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111 B(16) = DKMAP (IX,IY+1,IZ1) IF (B(10) .LT. B(16)) GO TO 111 B(17) = DKMAP (IX,IY+1,IZ2) IF (B(10) .LT. B(17)) GO TO 111 IBB = NINT ( (B(10)-B(17)) * 99.) IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111 B(18) = DKMAP (IX,IY+1,IZ3) IF (B(10) .LT. B(18)) GO TO 111 IBB = NINT ( (B(10)-B(18)) * 99.) IF ((IY.LT.LY2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111 B(19) = DKMAP (IX+1,IY+1,IZ2) IF (B(10) .LT. B(19)) GO TO 111 IBB = NINT ( (B(10)-B(19)) * 99.) IF ((IX.LT.LX2 .AND. IY.LT.LY2) .AND. IBB.EQ.0) GOTO 111 XX(1) = FLOAT(IX)/GTXYZS(1) XX(2) = FLOAT(IY)/GTXYZS(2) XX(3) = FLOAT(IZ2)/GTXYZS(3) CALL SMAXMN (XX, STEPX, XXMAX, SMAX) XXMAX(4) = SMAX CALL EL2AR2( XXMAX, 5, 4, XP,NPIEKS, NO, INDXP) 111 CONTINUE 222 CONTINUE 333 CONTINUE CALL SORTIN (INDXP,MXPEAK,NO, XP, 5, NPIEKS) RETURN END FUNCTION DKMAP(IX,IY,IZ) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) DKMAP=0.0 IF (IX.LT.ISS(1) .OR. IX.GT.LXYZS(1)) RETURN IF (IY.LT.ISS(2) .OR. IY.GT.LXYZS(2)) RETURN IF (IZ.LT.ISS(3) .OR. IZ.GT.LXYZS(3)) RETURN IADR = NUSXY * IZ + NUMS(1) * IY + IX - NUMSC IJX = ITAB(IADR) DKMAP = FLOAT( IJX ) / 99. RETURN END SUBROUTINE SMAXMN (X, STEPX, XMAX, SMAX) DIMENSION X(3), STEPX(3), XMAX(5) 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 /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48) DIMENSION DS(48,5,3), XX(3), SO(48), JM(3) DATA PMIN,PMAX /0.0,30254./ DO 210 NS=2,NSSY SO(NS) = SSMINF(X,NS,.TRUE.,NSMIN) DO 150 I = 1,3 CALL KERNAB(X,XX,3) XX(I) = X(I)-0.75*STEPX(I) DO 130 J = 1,5 XX(I)=XX(I)+0.25*STEPX(I) IF (J.EQ.3) THEN DS(NS,J,I) = 0.0 ELSE DS(NS,J,I) = SSMINF(XX,NS,.TRUE.,NSMIN) - SO(NS) ENDIF 130 CONTINUE 150 CONTINUE 210 CONTINUE SMAX=PMIN DO 3000 J3 = 1, 5 DO 2000 J2 = 1, 5 DO 1000 J1 = 1, 5 SMIN3=PMAX DO 300 NS=2,NSSY S3 = DS(NS,J1,1) + DS(NS,J2,2) + DS(NS,J3,3) + SO(NS) IF (SMIN3.GT.S3) SMIN3=S3 300 CONTINUE IF (SMAX.LT.SMIN3) THEN SMAX=SMIN3 JM(1)=J1 JM(2)=J2 JM(3)=J3 ENDIF 1000 CONTINUE 2000 CONTINUE 3000 CONTINUE DO 4000 I=1,3 XMAX(I) = X(I)+(0.25*JM(I)-0.75)*STEPX(I) 4000 CONTINUE RETURN END SUBROUTINE USET1G (IP, NP, ISET, I, BRI, MI, MAXI) DIMENSION IP(NP), ISET(MAXI) LOGICAL BRI DATA MXI / 0 / IF (I.EQ.0) THEN BRI=.FALSE. MXI = MAXI IF (MXI.GT.NP) MXI = NP IF (MI.GT.MXI .OR. MXI.LE.0) RETURN I=1 ISET(1)=1 IF (MXI.GE.2) ISET(2)=IP(1) RETURN ENDIF IF (BRI) THEN BRI=.FALSE. I=I-1 ENDIF J1=I+1 IF (J1.GT.MXI) J1=MXI DO 320 J = J1, 1, -1 N = MIN0(NP+J-MI, NP) IF (ISET(J)+1 .LE. IP(N)) THEN ISET(J)=ISET(J)+1 IF (J.LT.MXI) THEN DO 310 M=N, 2, -1 IF (ISET(J) .GT. IP(M-1)) GOTO 315 310 CONTINUE M=1 315 ISET(J+1) = IP(M) ENDIF I=J RETURN ENDIF 320 CONTINUE I=0 RETURN END SUBROUTINE DELXEQ ( X, NR, NOR, PATS, ENANTI, DMAX) DIMENSION X(5,NR) LOGICAL PATS, ENANTI LOGICAL PATSYM,TLATTI DATA TLATTI /.TRUE./ PATSYM=PATS N11=1 NOR1 = NOR IF (NOR1.LE.0) NOR1=1 DO 410 N2= 2, NR DO 310 NO= 1, NOR1 NO1 = NO IF (NOR.LE.0) NO1=0 IF (IEQUX(X(1,N2), X, N11, PATSYM, ENANTI, TLATTI, DMAX, NO1) * .EQ. 1) GOTO 410 310 CONTINUE N11 = N11+1 CALL KERNAB (X(1,N2), X(1,N11), 5) 410 CONTINUE NR=N11 RETURN END FUNCTION IEQUX(X1, X, N1, PATSYM,ENANTI,TLATTI, DMAX, NOR1) DIMENSION X1(3), X(5,N1) LOGICAL PATSYM,ENANTI,TLATTI COMMON /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) DIMENSION X1DATA(4), XEQ(3), XO1(3) LOGICAL DMAXCH, ALLEQ DMAXCH= .TRUE. IF (NOR1.GT.NOR) THEN IEQUX=0 RETURN ENDIF IF (NOR1 .NE. 0) THEN CALL VMINV (X1, ORIG(1,NOR1), XO1,3) CALL KERNAB(XO1, X1DATA, 3) ELSE CALL KERNAB(X1, X1DATA, 3) ENDIF 110 CALL SYMOPN (X1DATA, XEQ, PATSYM, ENANTI, TLATTI, ALLEQ) DO 210 N= 1, N1 IF (NOR1.NE.0 .AND. IDDPOL.NE.0) * CALL POLASH(XEQ,X(1,N), IDDPOL, RVPOL, XEQ) IEQUX = ISELFD (XEQ, X(1,N), DMAX) IF (IEQUX .EQ. 1) THEN RETURN ENDIF 210 CONTINUE IF (.NOT.ALLEQ) GOTO 110 RETURN END SUBROUTINE POLASH (XSH, X, IDD, RV, XSHFD) DIMENSION XSH(3),X(3), RV(3), XSHFD(3) DIMENSION SHFV(3) CALL VMINV (X,XSH, SHFV, 3) IF (IDD .EQ. 1) THEN IF(RV(1).GT.0.9 .AND. RV(2).GT.0.9 .AND. RV(3).GT.0.9) THEN SHFV(1)=(SHFV(1)+SHFV(2)+SHFV(3))/3. SHFV(2)=SHFV(1) SHFV(3)=SHFV(1) ELSE DO 110 I =1,3 110 SHFV(I)=SHFV(I)*RV(I) ENDIF ELSE IF (IDD.EQ.2) THEN DO 120 I =1,3 120 IF (RV(I).GT.0.9) SHFV(I)=0.0 ENDIF CALL VPLUSV (XSH, SHFV, XSHFD, 3) 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) ELSE IF (INV .EQ. -1) THEN CALL INVAB ( XEQ, XEQ, 3) RETURN ENDIF IF (NLT .GT. 1) CALL VPLUSV ( XS, TLATT(1,NLT), XEQ, 3) IF (INV .EQ. -1) CALL INVAB ( XEQ, XEQ, 3) 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 SYMOPN (XDATAS, XEQ, PATSYM, ENANTI, TLATTI, ALLSEQ ) DIMENSION XDATAS(4),XEQ(3) LOGICAL PATSYM, ENANTI, TLATTI, ALLSEQ 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, SMOD DIMENSION X(3), XEQL(3), XINTRM(3) IF (XDATAS(1).LT. 100.) THEN DO 110 I=3,1,-1 X(I)=XDATAS(I) 110 XDATAS(I+1)=XDATAS(I) XDATAS(1)=101. FIRST= .TRUE. NS=1 ITS=1 IF (PATSYM) ITS=0 NLT = 0 IF (TLATTI .AND. NLATT.GT.1) NLT=1 INV=0 IF (ENANTI .OR. ICENT.EQ.2 .OR. PATSYM) INV=1 ENDIF CALL SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQL, XINTRM) CALL NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ) FIRST = SMOD CALL KERNAB (XEQL, XEQ, 3) IF (ALLSEQ) THEN DO 210 I=1,3 210 XDATAS(I) = XDATAS(I+1) ENDIF RETURN END FUNCTION OCCUPX (X) DIMENSION X(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 XEQ(3,48), IXSELF(48), XEQM(3) LOGICAL PATSYM,TLATTI DATA PATSYM,TLATTI /.FALSE.,.FALSE./ DATA DMAX / 0.7/ OCCUPX = IMULT CALL ALLEQP (X, XEQ, 48, PATSYM, TLATTI, NEQP) CALL KERNZI (0, IXSELF, NEQP) DO 120 N= 1,NEQP OCCUPX = OCCUPX - IXSELF(N)*NLATT IF (IXSELF(N).EQ.1) GOTO 120 N1=N+1 DO 110 M=N1,NEQP DO 105 L= 1,NLATT IF (IXSELF(M).EQ.1) GOTO 110 CALL VPLUSV (XEQ(1,M), TLATT(1,L), XEQM, 3) IXSELF(M)=ISELFD (XEQ(1,N), XEQM, DMAX) 105 CONTINUE 110 CONTINUE 120 CONTINUE OCCUPX = OCCUPX/IMULT RETURN END SUBROUTINE ALLEQP (X, XEQ, NXQ, PATSYM,TLATTI, NEQP) DIMENSION X(3), XEQ(3,NXQ) LOGICAL PATSYM,TLATTI DIMENSION XDATAS(4) LOGICAL ALLSEQ, ENANTI DATA ENANTI /.FALSE./ CALL KERNAB (X,XDATAS,3) N=0 110 CONTINUE N = N + 1 CALL SYMOPN (XDATAS, XEQ(1,N), PATSYM, ENANTI, TLATTI, ALLSEQ) IF (.NOT. ALLSEQ .AND. N.LT.NXQ) GOTO 110 NEQP = N RETURN END SUBROUTINE DELIPO (X, N, DMAX) DIMENSION X(5,N) LOGICAL DMAXCH DMAXCH = .TRUE. N11=1 DO 410 N2= 2, N DO 210 N1= 1, N11 IF (ISELFD (X(1,N2), X(1,N1), DMAX) .EQ. 1) GOTO 410 210 CONTINUE N11 = N11+1 CALL KERNAB (X(1,N2), X(1,N11), 5) 410 CONTINUE N=N11 RETURN END SUBROUTINE INVAB ( A, B, N) DIMENSION A(N), B(N) DO 110 I = 1, N B(I) = -A(I) 110 CONTINUE 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 REDFCO (X, XOUT, N) DIMENSION X(N), XOUT(N) DO 110 I = 1, N XOUT(I) = X(I) - ANINT(X(I)) 110 CONTINUE RETURN END SUBROUTINE AR2SYM (AIJ, I, J, IJMAX, ARRAYS, NMAX) DIMENSION ARRAYS(NMAX) N = IPOIN1 (I,J, IJMAX) ARRAYS(N) = AIJ RETURN END FUNCTION IPOIN1 (I,J, IJMAX) IF (I.GE.J) THEN IPOIN1 = (J-1) * IJMAX - (J*J - J)/2 + I ELSE IPOIN1 = (I-1) * IJMAX - (I*I - I)/2 + J ENDIF RETURN END FUNCTION SQDIST (X, Y) 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 D(3) DO 120 I=1, 3 D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I)) 120 CONTINUE SQDIST=0.0 DO 130 I=1, 3 SQDIST=SQDIST+ * D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3)) 130 CONTINUE 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 (NRE1.NE.0) THEN CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ, NR) DO 100 I = NRE1, NR, -1 100 INDXHV(I+1) = INDXHV(I) INDXHV(NR) = N ELSE INDXHV(1) = N ENDIF 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 EL2AR2 (EL, I1, ISQ, AR2, MAX2, NELS, INDAR2) DIMENSION EL(I1), AR2(I1,MAX2), INDAR2( MAX2) DATA IND / 0 / IF ( NELS .EQ. MAX2 ) THEN IF ( EL(ISQ) .LT. AR2(ISQ,INDAR2(NELS)) ) RETURN IF (NELS .NE. INDAR2(NELS) ) THEN CALL KERNAB (AR2(1,NELS), AR2(1,INDAR2(NELS)), I1) DO 110 N = 1, NELS IF (INDAR2(N) .EQ. NELS) THEN IND = N GOTO 111 ENDIF 110 CONTINUE 111 INDAR2(IND) = INDAR2(NELS) ENDIF ELSE NELS = NELS + 1 ENDIF CALL KERNAB (EL, AR2(1,NELS), I1) CALL DETSEQ ( INDAR2,NELS, AR2,I1,NELS, ISQ, NELS-1) RETURN END SUBROUTINE SORTIN ( INDXHV,NIND, NHIGST, ARRAY,NDIM1,NE ) DIMENSION INDXHV(NIND), ARRAY(NDIM1,NE) DO 210 N = 1,NHIGST NR = INDXHV(N) IF (NR .EQ. N) GOTO 210 DO 110 I = 1,NDIM1 ELIN = ARRAY(I,N) ARRAY(I,N) = ARRAY(I,NR) ARRAY(I,NR)= ELIN 110 CONTINUE INDXHV(N) = N N1 = N + 1 DO 120 N2 = N1,NHIGST IF (INDXHV(N2) .EQ. N) THEN INDXHV(N2)=NR GOTO 210 ENDIF 120 CONTINUE 210 CONTINUE RETURN END SUBROUTINE PATTIN 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)), (IPRPAT, KEYS(8)) 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 = 300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB 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 / DO 111 I = 1, NUMTAB 111 ITAB(I) = 0 FMAX99 = 30254. FUNGR = 0. FUNSUM = 0. CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ) IF (KINQ.NE.0) CALL KERROR * ('Patterson file (FMAP) not found.', -1, 'PATTIN') 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) CALL KERROR * ('No Patteron function (error on file FMAP)', 0 , 'PATTIN' ) READ (IFMAP) NX, NZ, NYHALF, NY WRITE (LIS2,6) NX, NY, NZ 6 FORMAT (' Fourier grid X * Y * Z = ' , I3, 2(' *',I3) ) SCAL = 0.2 IF (PROGNM .EQ. 'PATTY ') SCAL = SCADEK ABSCAL = SCAL * FFTSC * VOLUM SINGPK = ORIGIN * ABSCAL * 18. /VOLUM IF (SWPRI) WRITE (LIS2, 138) FFTSC 138 FORMAT ('0Input 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 C-C : 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 LXYZ(I) = L 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, 171) NUMTAB, NUMXYZ 171 FORMAT (' Storage of Patterson, space:', I7,', needed:', I7) CALL KERROR (' PATTERSON TOO LARGE', 171, 'PATTIN' ) ENDIF DO 217 I = 1,3 217 GTXYZ(I) = NXYZ(I) NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1 IF (IPRPAT .GT. 0) THEN WRITE (CHOUT, FMT= * '('' Print input Patterson map to printer LIS2'')') CALL SHOUT2 WRITE (LIS2,24) (I, I=1, NUMX-1) 24 FORMAT ('1Input Patterson map, file FMAP'// * ' IY IZ IX = 0' , 24I4 / (12X, 25I4)) WRITE (LIS2, FMT='('' '')') ENDIF 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.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.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) FUN99 = 99. * ( FUN * SCAL + 25.) IF (FUN99 .LT. 0.0) FUN99 = 0.0 IF (FUN99 .GT. FMAX99) FUN99 = FMAX99 IF (FUN99 .GT. FUNGR) FUNGR = FUN99 IFUN99 = NINT(FUN99) LPAT(I3) = IFUN99 FUNSUM = FUNSUM + FUN99 IX = I3 - 1 IADR = IXYZC + IX ITAB(IADR) = IFUN99 IADR = JXYZC + IX IF (L.EQ.2) ITAB(IADR) = IFUN99 IF (K.NE.2) GOTO 40 IADR = KXYZC + IX ITAB(IADR) = IFUN99 IADR = LXYZC + IX IF (L.EQ.2) ITAB(IADR) = IFUN99 40 CONTINUE IF (IPRPAT .GT. 0) WRITE (LIS2,42) IY, IZ, (LPAT(I3), I3=1,NUMX) 42 FORMAT (2I4, 4X, 25I4 / (12X, 25I4)) 48 CONTINUE 50 CONTINUE IF (ILAUE .EQ.1 .AND. ICENT .EQ. 1) THEN CALL FILCLO (IFMAP, 'DELETE') ELSE CALL FILCLO (IFMAP, 'KEEP') ENDIF FUNSUM = FUNSUM / FLOAT(NUMXYZ) WRITE (LIS2,52) FUNGR, FUNSUM 52 FORMAT (' Largest scaled Patterson value is: ', 13X, F7.0/ * 20X, ' averaged value is: ', 9X, F7.0) RETURN END SUBROUTINE RDOUTT(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 /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 (ITPL, KEYS(7)) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY) LOGICAL SYMM2, SYMM3 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)) DATA IZD,IYZD / 0, 0/ DO 301 J= 1, 3 RARG(J) = AMOD(ARG(J),1.0) IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0 301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0 CALL SYMM (RX, RY, RZ) IF (ITPL.EQ.2) GOTO 2000 IF (ITPL.EQ.3) GOTO 2000 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) FUNNER = FLOAT( IJX ) / 99. 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 = FUNNER * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ IF (ITPL .NE. 4) GOTO 610 FUNF = AMAX1 (FUNF, 0.25 * (FUNNER + FUNX + FUNY + FUNZ) ) RETURN 610 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 IJX = ITAB(K222) FUNFAR = FLOAT( IJX ) / 99. IJX = ITAB(K122) FUNYZ = FLOAT( IJX ) / 99. IJX = ITAB(K212) FUNXZ = FLOAT( IJX ) / 99. IJX = ITAB(K221) FUNXY = FLOAT( IJX ) / 99. FMXY=FMX*FMY FMXZ=FMX*FMZ FMYZ=FMY*FMZ FMXYZ=FMX*FMYZ T1=FMYZ-FMXYZ T2=FMXZ-FMXYZ 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 2000 FUNF=-100. DO 713 IX=1,3 T = RARG(IX) * GTXYZ(IX) I = INT(T) DT=I-T IF (T.LT.0.) THEN IFAR(IX)=I I=I-1 IF (DT.GT.0.95) THEN I=I-1 ELSE IF (DT.LT.0.05) THEN IFAR(IX)=IFAR(IX)+1 ENDIF ELSE IFAR(IX)=I+1 IF (DT.LT.-0.95) THEN IFAR(IX)=IFAR(IX)+1 ELSE IF (DT.GT.-0.05) THEN I=I-1 ENDIF ENDIF 713 INEAR(IX)=I DO 720 IZ=INEAR(3),IFAR(3) SYMM3=IZ.LT.IS(3) .OR. IZ.GT.LXYZ(3) IF (.NOT.SYMM3) IZD=NXY*IZ-NUMC DO 720 IY=INEAR(2),IFAR(2) SYMM2=SYMM3 .OR. IY.LT.IS(2) .OR. IY.GT.LXYZ(2) IF (.NOT.SYMM2) IYZD=IZD+NX*IY DO 720 IX=INEAR(1),IFAR(1) IF (SYMM2 .OR. IX.LT.IS(1) .OR. IX.GT.LXYZ(1)) THEN RX=IX/GTXYZ(1) RY=IY/GTXYZ(2) RZ=IZ/GTXYZ(3) DO 715 J= 1, 3 RARG(J) = AMOD(RARG(J),1.0) IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0 715 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0 CALL SYMM(RX,RY,RZ) I1=NINT(RX*GTXYZ(1)) I2=NINT(RY*GTXYZ(2)) I3=NINT(RZ*GTXYZ(3)) IADR = NXY*I3 + NX*I2 + I1 - NUMC IJX = ITAB(IADR) FUN1 = FLOAT( IJX ) / 99. ELSE K111=IYZD+IX IJX = ITAB(K111) FUN1 = FLOAT( IJX ) / 99. ENDIF IF (FUN1.GT.FUNF) FUNF=FUN1 720 CONTINUE 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)) IF (KLAUE.LT.0) THEN IF (Y.LT.0.0) THEN X=-X Y=-Y Z=-Z ENDIF IF (X.LT.0.0) X=1.+X IF (Z.LT.0.0) Z=1.+Z RETURN ENDIF 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 ASYMS (ASY) DIMENSION ASY(6) 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 (LIS2, IFILE(8)) DIMENSION USX(3), TSV(3,4) LOGICAL ASUNIT CHARACTER *1 ALATS(7) DATA ALATS /'P', 'A', 'B', 'C', 'I', 'F', 'R'/ CALL UNITCS (USX, TSV, NT, ILATS) WRITE (LIS2, FMT='(/'' Subroutine ASYMS''/ * '' Symmetry map, unit cell:'', 3F8.3)') USX WRITE (LIS2, FMT='('' Centering: '', A1)') ALATS(ILATS) WRITE (LIS2, FMT='('' Translations: '', 4(''/'',3F4.1))') * ((TSV(I,II), I=1,3), II=1, NT) CALL ASYMPP (ILATS, ASY, ASUNIT) WRITE (LIS2,FMT='('' Asymmetric part:'',3X,3(''/'',2F8.3))') ASY ASY(2)=USX(1)*ASY(2) ASY(4)=USX(2)*ASY(4) ASY(6)=USX(3)*ASY(6) WRITE (LIS2,FMT='('' - for symm. map:'',3X,3(''/'',2F8.3)/)') ASY RETURN END SUBROUTINE UNITCS (USX, TSV, NT, ILATS) DIMENSION USX(3), TSV(3,4) 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 /ORIGNS/ NOR, ORIG(3,216), IDDPOL, RVPOL(3) DIMENSION IFREE(3) CALL KERNZA (0.0, USX, 3) NT=1 CALL KERNZA (0.0, TSV(1,1), 3) ILATS = 1 IF (IDDPOL.EQ.3) RETURN CALL KERNZI (0, IFREE, 3) I2=2 I3=3 DO 101 I=1,3 IF (IDDPOL.EQ.1) THEN IF(RVPOL(I).GT.0.01 .AND. * RVPOL(I2).LT.0.01 .AND. RVPOL(I3).LT.0.01 ) THEN IFREE(I)=1 GOTO 100 ENDIF ELSE IF (IDDPOL.EQ.2) THEN IF( RVPOL(I).LT.0.01 .AND. * (RVPOL(I2).GT.0.01 .OR. RVPOL(I3).GT.0.01) ) THEN IFREE(I)=1 GOTO 100 ENDIF ENDIF 100 IF (I2.EQ.1) I3=2 I2=1 101 CONTINUE I2=2 I3=3 DO 210 I=1,3 USX(I)=1.0 IF (IFREE(I).EQ.1) USX(I)=0.0 DO 115 LT=1,NLATT N1=1 IF (LT.EQ.1) N1=2 DO 110 N=N1,NOR IF ( (AMOD(ORIG(I2,N)+TLATT(I2,LT)+8.,1.0).LT.0.01 .OR. * IFREE(I2).EQ.1 ) .AND. * (AMOD(ORIG(I3,N)+TLATT(I3,LT)+8.,1.0).LT.0.01 .OR. * IFREE(I3).EQ.1 ) ) THEN IF (AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0).LT.USX(I)) * USX(I)=AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0) ENDIF 110 CONTINUE 115 CONTINUE IF (I2.EQ.1) I3=2 I2=1 210 CONTINUE DO 315 LT=1,NLATT N1=1 IF (LT.EQ.1) N1=2 DO 310 N=N1,NOR NC=0 ND=0 NT=NT+1 DO 305 J=1,3 TSV(J,NT)= AMOD(ORIG(1,N)+TLATT(1,LT)+8.,1.0) IF (TSV(J,NT).LT.0.001) NC=NC+1 IF (NC.GT.1) GOTO 306 IF (USX(J).GT.0.01) THEN IF (TSV(J,NT).GT.USX(J)-0.0001) GOTO 306 ELSE IF (TSV(J,NT).GT.USX(J)+0.0001) GOTO 306 ENDIF DO 302 MT=1,NT-1 302 IF (ABS(TSV(J,NT)-TSV(J,MT)).LT.0.01) ND=ND+1 305 CONTINUE IF (ND.LT.3) GOTO 310 306 NT=NT-1 310 CONTINUE 315 CONTINUE IF (NT.EQ.1) RETURN IF (NT.EQ.2) THEN I3=0 IF (ABS(TSV(1,2)) .LT. 0.0001) THEN ILATS=2 I1=2 I2=3 ELSE IF (ABS(TSV(2,2)) .LT. 0.0001) THEN ILATS=3 I1=1 I2=3 ELSE IF (ABS(TSV(3,2)) .LT. 0.0001) THEN ILATS=4 I1=1 I2=2 ELSE ILATS=5 I1=1 I2=2 I3=3 ENDIF IF (I3.EQ.0) I3=I1 IF (AMOD(TSV(I1,2)/USX(I1)-0.5, 1.0) .GT. 0.001) ILATS=1 IF (AMOD(TSV(I2,2)/USX(I2)-0.5, 1.0) .GT. 0.001) ILATS=1 IF (AMOD(TSV(I3,2)/USX(I3)-0.5, 1.0) .GT. 0.001) ILATS=1 RETURN ENDIF IF (NT.EQ.4) THEN DO 420 I=1,3 I1=I+1 IF (I1.GT.3) I1=1 I2=I-1 IF (I2.LT.1) I2=3 DO 410 N=2,NT IF (AMOD(TSV(I,N),1.0) .LT. 0.0001) THEN IF (AMOD(TSV(I1,N)/USX(I1)-0.5, 1.0) .GT. 0.001) RETURN IF (AMOD(TSV(I2,N)/USX(I2)-0.5, 1.0) .GT. 0.001) RETURN GOTO 420 ENDIF 410 CONTINUE RETURN 420 CONTINUE ENDIF IF (NT.EQ.3) THEN I1=0 DO 510 N=2,NT IF (I1.NE.23 .AND. * AMOD(TSV(1,N)/USX(1)-0.666667, 1.0) .LT. 0.001) THEN IF (AMOD(TSV(2,N)/USX(2)-0.333333,1.0) .GT. 0.001) RETURN IF (AMOD(TSV(3,N)/USX(3)-0.333333,1.0) .GT. 0.001) RETURN I1=23 GOTO 510 ELSE IF (I1.NE.13 .AND. * AMOD(TSV(1,N)/USX(1)-0.33333, 1.0) .LT. 0.001) THEN IF (AMOD(TSV(2,N)/USX(2)-0.666667,1.0) .GT. 0.001) RETURN IF (AMOD(TSV(3,N)/USX(3)-0.666667,1.0) .GT. 0.001) RETURN I1=13 GOTO 510 ENDIF RETURN 510 CONTINUE ILATS=7 ENDIF RETURN END SUBROUTINE ASYMPP (ILATS, ASY, ASUNIT) DIMENSION ASY(6) LOGICAL ASUNIT 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) ASUNIT = .TRUE. ASY(1)=0.0 ASY(3)=0.0 ASY(5)=0.0 GOTO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,1400) * ILAUE 100 ASY(2)=0.5 ASY(4)=1.0 ASY(6)=1.0 RETURN 200 CONTINUE ASY(2)=0.5 ASY(4)=0.5 ASY(6)=1.0 IF (IUNIQ.EQ.2 .AND.(ILATS.EQ.2 .OR. ILATS.EQ.4 .OR. ILATS.EQ.5)) * ASY(4)=0.25 IF (IUNIQ.EQ.3) THEN ASY(2)=1.0 ASY(6)=0.5 IF (ILATS.EQ.2 .OR. ILATS.EQ.3 .OR. ILATS.EQ.5) ASY(6)=0.25 ELSEIF (IUNIQ.EQ.1) THEN ASY(4)=1.0 ASY(6)=0.5 ENDIF RETURN 300 CONTINUE 400 CONTINUE 500 ASY(2)=0.5 ASY(4)=0.5 ASY(6)=0.5 IF (ILAUE .GE. 4) THEN IF (ILATS .EQ. 5) ASY(6)=0.25 GOTO 1220 ELSE IF (ILATS.EQ.4 .OR. ILATS.EQ.5 .OR. ILATS.EQ.6) ASY(2)=0.25 IF (ILATS.EQ.6) ASY(4)=0.25 ENDIF RETURN 600 CONTINUE 700 CONTINUE ASY(2)=1.0 ASY(4)=1.0 ASY(6)=0.5 GOTO 1220 800 ASY(2)=2./3. IF (ILATS.EQ.7) GOTO 1110 ASY(4)=2./3. ASY(6)=0.5 GOTO 1220 900 ASY(2)=2./3. IF (ILATS.EQ.7) GOTO 1110 ASY(4)=1./3. ASY(6)=1.0 GOTO 1220 1000 CONTINUE 1100 ASY(2)=2./3. IF (ILATS.EQ.7) GOTO 1110 ASY(4)=0.5 ASY(6)=0.5 GOTO 1220 1110 ASY(4)=2./3. ASY(6)=1./6. GOTO 1220 1200 ASY(2)=2./3. ASY(4)=1./3. ASY(6)=0.5 1220 ASUNIT = IUNIQ.EQ.3 IF (.NOT. ASUNIT) GOTO 100 RETURN 1300 CONTINUE 1400 ASY(2)=0.5 ASY(4)=0.5 ASY(6)=0.5 IF (ILATS.EQ.6) ASY(6)=0.25 IF (ILATS.EQ.6 .AND. ILAUE.EQ.14) ASY(4)=0.25 IF (ILATS.EQ.5 .AND. ILAUE.EQ.14) ASY(6)=0.25 RETURN END FUNCTION NQSET (RSET, N) DIMENSION RSET(N) NQSET=0 DO 110 M=1,N JC=NINT(RSET(M)) IF (JC.GT.10) JC=10*JC IF (JC.GT.100) JC=100*JC 110 NQSET = NQSET + JC RETURN END SUBROUTINE XHELIV (X,NHX, ASVXX,NASV, AMINHL, UX, NUX) PARAMETER (MXPKS=150, MXHH=16, MXPP=128, MXUX=MXPP/4) DIMENSION X(3,NHX), ASVXX(5,NASV), UX(MXHH+6,MXUX) 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 /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD COMMON /PATDAT/ SCADEK,PATAD, SCPAT,AMI1,AMI2,PLIM,PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (MXVHL=8*MXUX) DIMENSION V(5,4*MXPKS+1),VVP(MXPKS), VVP1(MXPKS), * R1(3), UUX(MXHH+6), INDX(MXUX), INDXV(MXVHL), * VEQ(3,48), R1EQ(3,MXHH), VML(3,4) LOGICAL PATSYM,TLATTI, L2L, FIRST, PATSR1 DATA DMAX,DMAXP,PLIMHL,P1,NEQV,NV,LL,NUXM /0.8,0.2,.0,.0,1,0,0,0/ DATA SUMIW /0.0/ DATA PATSR1,PATSYM,TLATTI,FIRST /.FALSE.,.TRUE.,.FALSE.,.TRUE./ NUX=0 AMINHL=0.0 NX=NHX/NLATT IF (NHEAVY.GT.2) GOTO 2000 IF (LTHEAV.EQ.NELMS) GOTO 2000 IF (LTHEAV.NE.LTHV .OR. NHX.LT.NINT(HEAVYN*IMULT)) GOTO 2000 IF (NX.LE.1 .OR. NX.GT.MXHH .OR. NVPS.LE.0) GOTO 2000 IF (0.7*NCELLZ(1)**2 .GT. NCELLZ(LTHV)**2) GOTO 2000 L2L = NHX.LT.IMULT ISQ=MXHH+6 NDIM1=ISQ NP=NVPS IF (FIRST) THEN FIRST=.FALSE. CALL KERNZA (0., UUX, NDIM1) IF (ABS(SC2DEK-1.).GT.0.0001) THEN DO 100 N=2,NVPS 100 VP(4,N)=SC2DEK*VP(4,N) + PATADD SC2DEK=1.0 ENDIF DO 110 L=LTHEAV+1,NELMS IF (0.7*NCELLZ(LTHEAV+1) .LT. NCELLZ(L)) THEN LL=L NUXM=NUXM+NCELTY(L) ENDIF 110 CONTINUE NUXM=NUXM/NLATT IF (NUXM.GT.MXVHL) NUXM=MXVHL NUXM=NUXM/(NSYMM*ICENT) IF (NUXM.GT.MXUX) NUXM=MXUX PLIMHL=(PLIMC(LTHEAV,LL)-PATAD)*ICENT SMLIM=0.3*PLIMHL/ICENT ITSTQV=2 NV=0 NVQ=4*MXPKS NEQV=1 DO 150 M=2,NP IF (VP(4,M).LT.PLIMHL+PATAD) GOTO 140 CALL ALLEQP (VP(1,M), VEQ, 48, PATSYM,TLATTI, NEQV) NVQ=NVQ-NEQV DO 130 N=1,NEQV NV=NV+1 V(5,NV)=0.001 CALL KERNAB (VEQ(1,N),V(1,NV),3) 121 IF (V(1,NV).GT. 0.00001) GOTO 130 V(1,NV)=V(1,NV)+1.0 GOTO 121 130 V(4,NV)=M+0.01 140 IF (M.EQ.NP .OR. NVQ.LT.NEQV) THEN CALL DELIP2 (V, NV, VVP1, NP, DMAXP) NVQ=4*MXPKS-NV IF (NVQ.LT.NEQV) GOTO 160 ENDIF 150 CONTINUE 160 V(4,NV+1)=0.001 VVP1(1)=1.0 DO 170 M=1,NP 170 VVP1(M)=VVP1(M)/NEQV ISUMH=0 IH=0 DO 180 I=1,LTHV ICELH=NCELTY(I)/NLATT IF (IH+ICELH.GT.NX) ICELH=NX-IH IF (ICELH.EQ.0) GOTO 185 IH=IH+ICELH ISUMH = ISUMH + ICELH*NCELLZ(I) 180 CONTINUE 185 ILMAX=(NV*ICENT)/IH IF (ILMAX.GT.NUXM*ICENT*NSYMM) ILMAX=NUXM*ICENT*NSYMM IL=NX-IH ISUML=IL*NCELLZ(LTHV) DO 190 I=LTHV+1,LL ICELL=NCELTY(I)/NLATT IF (IL+ICELL.GT.ILMAX) ICELL=ILMAX-IL IF (ICELL.EQ.0) GOTO 195 IL=IL+ICELL 190 ISUML=ISUML+ (ICELL * NCELLZ(I)) 195 SUMIW=ISUML*ISUMH ENDIF DO 210 M=1,NP 210 VVP(M)=(VP(4,M)-PATADD)*VVP1(M) PHT= ICENT*(PLIMC(LTHV,LTHV)-PATAD) DO 240 NA=1,NASV DO 230 N =1,NV M=V(4,N) IF (VVP(M).LT.PLIMHL) GOTO 230 IF (ISELFD(V(1,N),ASVXX(1,NA),DMAXP) .EQ. 1) THEN PH=ASVXX(5,NA)*VVP1(M) IF (PH.GT.PHT) PH=PHT VVP(M)=VVP(M)-PH GOTO 240 ENDIF 230 CONTINUE 240 CONTINUE L2L=L2L .OR. NCELLZ(LL).GE.20 NHIGV=0 DO 310 N=1,NV I=V(4,N) V(5,N)=-100. IF (VVP(I).GT.PLIMHL) THEN CALL VMINV(X(1,1),V(1,N),R1,3) PR1=SMINF(R1,X,NX,1,0)-PATAD IF (L2L) THEN SPM= SSMINF (R1,0,.TRUE.,NEMIN) SPM=((SPM-PATAD) * NCELLZ(1)) / NCELLZ(LL) PR1=AMIN1(PR1,SPM) ENDIF V(5,N)=PR1 IF (V(5,N).GT.0.3*PLIMHL .AND. NHIGV.LT.MXUX) NHIGV=NHIGV+1 ENDIF 310 CONTINUE IF (NHIGV.EQ.0) GOTO 2000 ISQV=5 CALL DETSEQ (INDXV, NHIGV, V, 5, NV, ISQV, 0) NV1=NHIGV DO 710 IN=1,NV1 N=INDXV(IN) I=V(4,N) IF (V(1,N).GT.0.0) THEN CALL VMINV(X(1,1),V(1,N),R1,3) PR1=V(5,N) UUX(1)=N+0.1 UUX(ISQ)=-100. NOV2R1=0 DO 530 M=2,NX CALL VMINV(X(1,M),R1,VML(1,1),3) DO 510 L=2,NLATT 510 CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3) DO 520 K=1,NV KI=V(4,K) IF (VVP(KI).GT.PLIMHL) THEN DO 515 L=1,NLATT IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN UUX(M)=K+0.1 GOTO 530 ENDIF 515 CONTINUE ENDIF 520 CONTINUE UUX(M)=0.1 NOV2R1=NOV2R1+1 IF (PR1.LT.PLIMHL .OR. FLOAT(NOV2R1)/NX .GT. 0.15) GOTO 701 530 CONTINUE UUX(ISQ-1)=30254. PMIN=UUX(ISQ-1) DO 550 M=1,NX NI=UUX(M) IF (NI.EQ.0) GOTO 550 NI=V(4,NI) IF (PMIN.GT.VVP(NI)) PMIN=VVP(NI) 550 CONTINUE IF (PMIN.LT.PR1) PMIN=PR1 PMIN = ((NX-NOV2R1)*PMIN + NOV2R1*PR1)/NX IF (PMIN.LT.PLIMHL) GOTO 701 UUX(ISQ)=PMIN CALL ALLEQP (R1, R1EQ, MXHH, PATSR1, TLATTI, NEQR) DO 630 I=1,NEQR DO 590 J=1,3 R1EQ(J,I)=R1EQ(J,I)-ANINT(R1EQ(J,I)) 590 IF (R1EQ(J,I).LT.0.0) R1EQ(J,I)=R1EQ(J,I)+1.0 IF (I.NE.1) THEN DO 595 J=1,3 IF (R1(J).LT.R1EQ(J,I)-0.0000001) GOTO 597 IF (R1(J) .GT. R1EQ(J,I)+0.0000001) GOTO 596 595 CONTINUE ENDIF 596 CALL KERNAB(R1EQ(1,I),R1,3) 597 IF (I.EQ.1) GOTO 630 CALL VMINV (X(1,1), R1EQ(1,I), VML(1,1), 3) DO 602 L=2,NLATT 602 CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3) DO 610 IK=IN+1,NV1 K=INDXV(IK) IF (V(1,K).LT.0.0) GOTO 610 DO 603 L=1,NLATT IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN 601 IF (V(1,K).LT.0.0) GOTO 610 V(1,K)=V(1,K)-1.0 GOTO 601 ENDIF 603 CONTINUE 610 CONTINUE 630 CONTINUE CALL KERNAB (R1, UUX(MXHH+1), 3) UUX(ISQ-2)=PR1 IF (UUX(ISQ).GT.PLIMHL) * CALL EL2AR2 (UUX, NDIM1, ISQ, UX,MXUX, NUX, INDX) ENDIF 701 IF (V(1,N).GT. 0.00001) GOTO 710 V(1,N)=V(1,N)+1.0 GOTO 701 710 CONTINUE IF (NUX.EQ.0) GOTO 2000 SUM=0.0 IF (NUX.GT.NUXM) NUX=NUXM DO 930 IJ=1,NUX J=INDX(IJ) PMINJ= UX(ISQ,J) DO 920 I=1,NX M=UX(I,J) IF (M.EQ.0) GOTO 920 M=V(4,M) P1=AMAX1(VVP(M),0.0) IF (PMINJ.LT.P1) P1=PMINJ VVP(M)=VVP(M)-PMINJ SUM=SUM+P1 920 CONTINUE 930 CONTINUE SUM=(IMULT*SUM)/(NLATT*SCPAT) IF (ICENT.EQ.1) SUM=2.0*SUM AMINHL = SUM/SUMIW 2000 CONTINUE IF (AMINHL.LT.0.0001) AMINHL=0.0001 RETURN END SUBROUTINE DELIP2 (V, NV, VVP, NAV, DMAX) DIMENSION V(5,NV), VVP(NAV) CALL KERNZA(0.0, VVP, NAV) N11=1 M2=V(4,1) VVP(M2)=VVP(M2)+1.0 DO 410 N2= 2, NV M2=V(4,N2) DO 210 N1= 1, N11 M1=V(4,N1) IF (M1.NE.M2) GOTO 210 IF (ISELFD (V(1,N2), V(1,N1), DMAX) .EQ. 1) THEN GOTO 410 ENDIF 210 CONTINUE N11 = N11+1 CALL KERNAB (V(1,N2), V(1,N11), 5) VVP(M2)=VVP(M2)+1.0 410 CONTINUE NV=N11 RETURN END SUBROUTINE FRALIM (F1,F2,IFPL, FRAC) PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 ) COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) 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 (LIS2, IFILE(8)) DIMENSION FPT(10), IPT(10) FRAC=0.0 L=LTHV NCO=NCONS IF (NCO.LE.1) RETURN IFPLL=IFPL DF = (F2-F1)/8.0 NCRH=(NCO*NCO-NCO)/2 PT = SCPAT * NCELLZ(L)**2 F=F1-DF FPT(1)=0.0 DO 110 N=2,10 F=F+DF 110 FPT(N) = F*PT + PATAD CALL KERNZI(0,IPT,10) DO 230 J=1,NPCT-1 DO 220 I=J+1,NPCT IJ=IPOIN1(I,J,NPCT) DO 210 N=1,10 IF (P1X2(IJ).LT.FPT(N)) GOTO 220 210 IPT(N)=IPT(N)+1 220 CONTINUE 230 CONTINUE IF (IPT(2).LT.NCRH) RETURN FRAC=F1 IF (IFPLL.GT.IPT(2)) GOTO 400 F=F1 DO 310 N=3,10 IF (IPT(N).LT.IFPLL) THEN FRAC=F + (DF*(IPT(N-1)-IFPLL))/(IPT(N-1)-IPT(N)) IF (FRAC.GT.F2) FRAC=F2 IF (FRAC.LT.F1) FRAC=F1 GOTO 400 ENDIF F=F+DF 310 CONTINUE FRAC=F2 400 CONTINUE WRITE (LIS2, FMT='('' F FPT IPT'')') F=0.0 DO 240 N=1,10 WRITE (LIS2, FMT='(F10.3, F10.3, I10)') F, FPT(N), IPT(N) IF (N.EQ.1) F=F1-DF 240 F=F+DF WRITE (LIS2, FMT='('' NCRH IFPL '')') WRITE (LIS2, FMT='(I10, I10)') NCRH, IFPL WRITE (LIS2, FMT='('' F1 F2 FRAC '')') WRITE (LIS2, FMT='(F10.3, F10.3, F10.3)') F1, F2, FRAC RETURN END SUBROUTINE VECCHL (X, NX, NPMAX, CONTHL) DIMENSION X(5,NX) COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8), * PLIMS(10),PLIMC(10,10) PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4, * MXHH=16, MXPP=128, MXUX=MXPP/4) COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP), * ASVECT(5,MAXASV),NASV DIMENSION UX(MXHH+6,MXUX) CALL VECCAP (X, NX, ASVECT, NASV, XCELL, NPCELL, NAXCEL) DO 110 NV = 1, NASV CALL GRDOUT (ASVECT(1,NV), FUNF) ASVECT(5,NV) = FUNF-PATAD 110 CONTINUE CONTHL=0.0 IF (NPCELL.LE.NPMAX) * CALL XHELIV(XCELL,NPCELL,ASVECT,NASV,CONTHL, UX, NUX) RETURN END SUBROUTINE DISCAB(XZ,NSTSXZ, NPMAX) PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5, MXINXZ=MXSTSX) DIMENSION XZ(IXZ,MXSTSX), INXZ(MXINXZ) COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV, * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV LOGICAL M1DONE DATA FOM1, NH1 /0.0, 0/ IF (NSTSXZ.LE.0) RETURN IF (NHEAVY.GT.2) RETURN IHL =5*MXHEAV-2 IFOM=5*MXHEAV+3 ISW =5*MXHEAV M1DONE=.FALSE. LTHVV=LTHV DO 310 N=1,NSTSXZ NH=XZ(5*MXHEAV+1,N) ATOMS=0.0 DO 110 J=1,NH 110 ATOMS=ATOMS+XZ(5*J-1,N) IF (N.EQ.1) THEN IF (ATOMS.LT.HEAVYN-0.01) RETURN IF (XZ(IHL,1).GT. 0.00005) RETURN LTHV=LTHEAV FOM1=XZ(IFOM,1) NH1=NH ELSE FOM = XZ(IFOM,N) IF (FOM.GT.0.8*FOM1 .AND. ATOMS.GT.HEAVYN-0.01 .AND. * XZ(IHL,N).LT. 0.00005) THEN 211 IF (M1DONE) THEN M=N MH=NH ELSE M=1 MH=NH1 ENDIF CALL VECCHL (XZ(1,M), MH, NPMAX, CONTHL) IF (M.EQ.1 .AND. CONTHL.LT. 0.00005) GOTO 410 XZ(IHL,M)=CONTHL XZ(IFOM,M)=XZ(IFOM,M)+CONTHL*0.5*XZ(ISW,M) M1DONE=.TRUE. IF (M.EQ.1) GOTO 211 ENDIF ENDIF 310 CONTINUE NHIGXZ=NSTSXZ CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NSTSXZ, IFOM, 0) CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX) 410 LTHV=LTHVV RETURN END SUBROUTINE SYSRCH(X,IP,N,XX,NX) PARAMETER (MXHEAV=20) DIMENSION X(IP,MXHEAV), XX(4,MXHEAV) 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 AA(3),A(3), S(3), AVS(3), DMAX(3), X2(3), X1(3,MXHEAV), * KSEQ(MXHEAV), ISEQ(MXHEAV), LA(MXHEAV), RSYMM2(3),TSYMM2(3) DATA DMAX, DMAXA / 0.02, 0.02, 0.02, 0.35/ NEQMAX=0 IF (NSYMM.EQ.1 .AND. ICENT.EQ.1) THEN DO 105 I=1,N CALL KERNAB(X(1,I),XX(1,I),3) XX(4,I)=1.0 105 CONTINUE NX=N RETURN ENDIF IF (ICENT.EQ.2) THEN DO 106 K=1,3 RSYMM2(K)=-1. 106 TSYMM2(K)=0.0 ELSE DO 107 K=1,3 RSYMM2(K)=IRSYMM(K,K,2) 107 TSYMM2(K)=TSYMM(K,2) ENDIF DO 610 I=1,N MXNEQ= N-I+1 IF (MXNEQ.LE.NEQMAX) RETURN DO 520 L=1,NLATT DO 110 K=1,3 110 AA(K)=RSYMM2(K) * X(K,I) + TSYMM2(K) + TLATT(K,L) DO 510 J=I,N DO 210 K=1,3 A(K)=AA(K)-X(K,J) IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN S(K)=A(K)/(1.-RSYMM2(K)) ELSE IF (ABS(AMOD(A(K),1.0)) .GT. DMAX(K)) GOTO 510 S(K)=0.0 ENDIF 210 CONTINUE DO 310 M=I,N DO 310 K=1,3 310 X1(K,M) = X(K,M)+S(K) CALL KERNZI (0, KSEQ,N) CALL KERNZI (1, LA,N) LA(I)=L KSEQ(I)=J NEQ=1 KSEQ(J)=I IF (J.NE.I) NEQ=NEQ+1 DO 410 I1=I+1,N DO 405 L1=1,NLATT IF (KSEQ(I1).NE.0) GOTO 410 DO 320 K=1,3 320 X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1) DO 400 J1=I1,N IF (KSEQ(J1).NE.0) GOTO 400 IF (ISELFD(X1(1,J1), X2, DMAXA) .NE. 1) GOTO 400 LA(I1)=L1 KSEQ(J1)=I1 NEQ=NEQ+1 KSEQ(I1)=J1 IF (J1.NE.I1) NEQ=NEQ+1 GOTO 410 400 CONTINUE 405 CONTINUE 410 CONTINUE IF (NEQ.LE.NEQMAX) GOTO 510 NEQMAX=NEQ CALL KERNAI (KSEQ,ISEQ,N) NSUM=0 AVS(1)=0.0 AVS(2)=0.0 AVS(3)=0.0 DO 440 I1=I,N IF (KSEQ(I1).EQ.0) GOTO 440 L1 = LA(I1) J1 = KSEQ(I1) DO 430 K=1,3 A(K)=RSYMM2(K)*X1(K,I1)+TSYMM2(K)+TLATT(K,L1) - X1(K,J1) IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN S(K)=A(K)/(1.-RSYMM2(K)) ELSE S(K)=0.0 ENDIF AVS(K)=AVS(K)+S(K) 430 CONTINUE NSUM=NSUM+1 KSEQ(I1)=0 KSEQ(J1)=0 440 CONTINUE DO 445 K=1,3 445 AVS(K)=AVS(K)/NSUM NX=0 DO 480 I1=I,N IF (ISEQ(I1).EQ.0) GOTO 480 NX=NX+1 J1=ISEQ(I1) L1=LA(I1) DO 450 K=1,3 IF (I1.NE.J1) X1(K,I1) = X1(K,I1)+AVS(K) 450 X1(K,J1) = X1(K,J1)+AVS(K) DO 460 K=1,3 X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1) X2(K)=X2(K)-NINT(X2(K)-X1(K,J1)) X2(K)=X2(K)+X1(K,J1) X2(K)=X2(K)/2. XX(K,NX)=X2(K) 460 CONTINUE XX(4,NX)=1.0 IF (I1.EQ.J1) XX(4,NX)=0.5 ISEQ(I1)=0 ISEQ(J1)=0 480 CONTINUE 510 CONTINUE 520 CONTINUE 610 CONTINUE RETURN END SUBROUTINE SYMPRI 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 (LIS2, IFILE(8)) COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC * ,GTXYZS(3), LXYZS(3), FSTPSY(3) COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3) PARAMETER (NUMTAB =300000) COMMON / / ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION FLINE(100) WRITE (LIS2, FMT='(''NUM , NUMS'', 3I5,3X, 3I5/)') NUM, NUMS DO 333 JZ = ISS(3), NUMS(3) WRITE (LIS2, FMT='(/''JZ='', I5, '' ---------------------''/)') JZ DO 222 JY = ISS(2), NUMS(2) WRITE (LIS2, FMT='(''JZ, JY, JX = '',3I5,'' ....'')') JZ,JY,ISS(1) L = 0 DO 111 JX = ISS(1), NUMS(1) IADR = NUSXY * JZ + NUMS(1) * JY + JX - NUMSC IJX = ITAB(IADR) FUNF = FLOAT( IJX ) / 99. L = L + 1 FLINE(L) = FUNF 111 CONTINUE WRITE (LIS2, FMT='( 10F7.1)') (FLINE(LL), LL=1,L) 222 CONTINUE 333 CONTINUE RETURN END