PROGRAM ORIENT CCCCCCCCCCCCCCCCCCCCCCCCCC let op regel 226 ==> 19 Feb. 96 ==> SWITCH(1) *************************** File: U625002 ORIENT FORTRAN N = ORIENT FOR **** Note: the last part of ***************** Last update: 11 Nov. 1999 **** this file is: ORIENT2 **** Source: Nordman, Strumpel, G.Beurskens **** Find: CSUBFILE ORIENT2 **** ORIENT2 is also used in Program PATTY *ORIENT LOG of recent modifications (last on top C 11 Nov 99 : blank commons aangepast aan ITAB lengte 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 (IMFUN, IFILE(13)), (IPDEK, IFILE(14)) EQUIVALENCE (LIS2, IFILE(8)) LOGICAL XBIG EQUIVALENCE (XBIG, SWITCH(14)) CALL KEPROG ('ORIENT') WRITE (LIS2, FMT = '('' Last ORIENT update: 11 Nov. 1999'')') SWITCH(1) = .FALSE. CALL ORVIN (MPARIN) CALL ORVEC CALL ORDEK CALL MORV CALL MAPSIG IF (MPARIN.GT.0) GOTO 200 CALL REGION CALL MORV CALL MAPSIG 200 CALL SIGSEL (DELC) IF (DELC .LT. 0.35) GOTO 222 DO 220 I = 1,2 CALL MORV CALL MAPSIG CALL SIGSEL (DELC) IF (DELC .LT. 0.35) GOTO 222 220 CONTINUE 222 CALL EULOUT CALL FILCLO (IMFUN, 'DELETE') CALL KEPROX WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 99 END SUBROUTINE ORVIN (MPARIX) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (ICRYS, IFILE(3)), (ICON, IFILE(4)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (KLAUE, KEYS(6)) , (IPRPAT, KEYS(8)) EQUIVALENCE (IPRDEK, KEYS(9)), (IPRSIG, KEYS(10)) LOGICAL SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) LOGICAL XBIG EQUIVALENCE (XBIG, SWITCH(14)) 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 (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) CHARACTER *6 PRIMAP(3) PARAMETER (LITAM = 7) CHARACTER *6 LITA(LITAM) DATA LITA /'ORIENT', 'VMAX', 'PARAMS', 'MIN', 'XBIG', * 'PRIMAP', ' ' / DATA PRIMAP / 'PATIN', 'DEK', 'MAPSIG' / D2R = ATAN(1.0) / 45.0 VMAXIN = -1. FVMIN = -1. KWVLEN = 0 MPAR = 0 DELC = 0. MININ = 0 NCONIN = 0 CALL KERNZI (0, MM, 3) CALL KERNZI (0, MINM, 3) CALL KERNZI (0, MIN4, 4) CALL RDCRYS (ICRYS) CALL FILCLO (ICRYS, 'KEEP') GOTO * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE 101 KLAUE = 1 GOTO 177 102 IF (IUNIQ .EQ. 1) GOTO 101 IF (IUNIQ .EQ. 3) GOTO 104 KLAUE = 2 GOTO 177 103 KLAUE = 3 GOTO 177 104 KLAUE = 4 177 CALL RDCOND (ICON, LITA, LITAM, KEND) IF (KEND .EQ. -1) THEN WRITE (LIS1, FMT='('' No CONDA file: default run'')') GOTO 910 ENDIF IF (KEND .EQ. 0) GOTO 900 NCONIN = NCONIN + 1 IF (NCONIN .EQ. 2) WRITE(LIS1, FMT='('' CONDA control data:'')') GOTO (177, 200, 300, 400, 500, 600, 177), KEND 200 VMAXIN = FNUM(1) IF (VMAXIN.LE.0.0 .AND. NFNUM.GT.1) GOTO 202 WRITE (LIS1, FMT ='( '' VMAX input ='', F7.2)' ) VMAXIN IF (VMAXIN .LT. 1.1) CALL KERROR (' Error: No value for VMAX ', * -1, ' ORVIN' ) 202 IF (NFNUM .GT. 1) THEN KWVLEN = NINT(FNUM(2)) IF (KWVLEN .EQ. 1) WRITE (LIS1, FMT='( * '' Sorting of vectors on Weight * SQRT(Vector-length)'')') IF (KWVLEN .GT. 1) WRITE (LIS1, FMT='( * '' Sorting of vectors on Weight * Vector-length'')') ENDIF GOTO 177 300 MPAR = MPAR + 1 IF (MPAR .EQ. 1) WRITE (LIS1, FMT='('' Set nr. '', * '' Abeg Ainc Nr. Bbeg Binc Nr. Cbeg Cinc Nr.'')') I =0 DO 310 J=1,3 PAR1(J,MPAR) = FNUM(I+1) PAR2(J,MPAR) = FNUM(I+2) NPAR(J,MPAR) = NINT(FNUM(I+3)) IF (NPAR(J,MPAR).LE.0) GOTO 800 310 I = I + 3 WRITE (LIS1,312) MPAR, * (PAR1(J,MPAR), PAR2(J,MPAR), NPAR(J,MPAR), J=1,3) 312 FORMAT (' Set', I3, 3(F10.1, F6.1, I3)) IF (NFNUM .NE . 9) GOTO 800 DO 314 J=1,3 IF (NPAR(J,MPAR).LE.0) GOTO 800 IF (NPAR(J,MPAR).GT.1 .AND. PAR2(J,MPAR).LT.0.01) GOTO 800 314 CONTINUE DELC = DELC + PAR2(3,MPAR) GOTO 177 400 IF (NFNUM .EQ. 4) GOTO 440 IF (FNUM(1).GT.0.05 .AND. FNUM(1).LT.0.95) GOTO 460 CALL KERF2I (FNUM, MINM, 3) WRITE (LIS1, FMT = * '('' MIN values: M = '' , 6I3)' ) (MINM(I), I =1,NFNUM) IF (NFNUM.GT.3 .OR. NFNUM.LT.1) GOTO 800 IF (NFNUM.EQ.1 .AND. MINM(1).LE.0) GOTO 800 IF (NFNUM.EQ.2 .AND. MINM(2).LE.MINM(1)) GOTO 800 IF (NFNUM.EQ.3 .AND. MINM(3).LE.MINM(2)) GOTO 800 MININ = NFNUM GOTO 177 440 CALL KERF2I (FNUM, MIN4, 4) IF (MIN4(1).LE.0 .OR. MIN4(2).LT.MIN4(1) .OR. * MIN4(3).LT.MIN4(2) .OR. MIN4(4).LT.MIN4(3) ) * CALL KERROR('Incorrect MIN - parameters...', 440, 'ORVIN') GOTO 177 460 FVMIN = FNUM(1) GOTO 177 500 CONTINUE XBIG = .TRUE. WRITE (LIS1, FMT ='('' XBIG parameter for eXtra BIG problem'')') GOTO 177 600 CONTINUE DO 610 I = 2, NLIT CALL KEREQ6 (LIT(I), PRIMAP, 3, LEND) GOTO (601, 602, 603), LEND WRITE (CHOUT, FMT='('' Incorrect PRIMAP parameters '')') CALL SHOUT GOTO 800 601 IPRPAT = LIS2 GOTO 610 602 IPRDEK = LIS2 GOTO 610 603 IPRSIG = LIS2 610 CONTINUE WRITE (CHOUT, FMT='('' Print'', A66)') CHIN(7:72) CALL SHOUT2 GOTO 177 800 CALL KERROR (' Input for ORIENT not correct ', -6 ,'ORVIN') 900 IF (MPAR .GT. 0) DELC = AMIN1 (10., DELC / FLOAT(MPAR)) 910 IF (DELC .LT. 0.1) DELC=10. IF (MPAR .GT. 0) WRITE (LIS1, FMT='( * '' Starting value of DELC (aver. increment C):'',F6.2)') DELC CALL FILCLO (ICON, 'KEEP') MPARIN = MPAR MPARIX = MPAR CALL READAT RETURN END SUBROUTINE READAT COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IATOMS, IFILE(1)) EQUIVALENCE (IATMOD, IFILE(2)) EQUIVALENCE (IATOLD, IFILE(10)) EQUIVALENCE (LIS1, IFILE(7)) 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 (MAXAT = 1026) COMMON /ATODAT/ NAT, ATXYZ(10, MAXAT), IZAT(MAXAT) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER *6 ATNAME PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) CALL KERROR ('Error on file ATMOD', -1,'READAT') CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) IF (NAT .LE. 1) CALL KERROR ('Only one atom' , -1, 'READAT') CMAX = 360. ISM = 0 IF (LIT(NLIT) .EQ. 'SYMX') ISM = NINT(FNUM(NFNUM)) IF (ISM .GE. 2) CMAX = CMAX / FLOAT(ISM) CHOUT='Starting coords for rotation search (ABC=000) for compound' CHOUT(60:65) = CCODE WRITE (LIS1, 406) 406 FORMAT (' Starting Cartesian coordinates for rotation search'/ * ' (model with angles A B C = 0 0 0 from file ATMOD)'/ * ' Nr atomnm',5X,'x',7X,'y',7X,'z Z(At.nr.)' ) DO 420 I = 1,NAT ATXYZ(4,I) = FLOAT(IZAT(I)) WRITE (LIS1, 410) I, ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I) 410 FORMAT (I5, 2X, A6, 3F8.3, I5) 420 CONTINUE RETURN END SUBROUTINE ORVEC 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 (LDPU, IFILE(2)), (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)), (IDDL, IFILE(9)) EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28)) LOGICAL NIJM, SWPRI EQUIVALENCE (NIJM, SWITCH(1)), (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 (MAXAT = 1026) COMMON /ATODAT/ NAT, ATXYZ(10, MAXAT), IZAT(MAXAT) PARAMETER (MAXVE = 2000) COMMON /XKLADX/ TAB(50), 2 VEX(MAXVE), VEY(MAXVE), VEZ(MAXVE), VLEN(MAXVE), 2 WI(MAXVE), W(MAXVE), KFLAG(MAXVE), IW(MAXVE) PARAMETER (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DIMENSION PATP(8) PARAMETER (VVMAX = 12.) DATA DEL /.01/ DATA IMAX2, DELY, DEL2Y / 0, 0.0, 0.0 / WRITE (LIS2, 110) 110 FORMAT (' Generate, weight and select vectors') CALL LOGRD (IDDL, 'SINGPK', KLOG) IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'VEC') IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR * ('DDLOG file not correct, SINGPK or ORIGIN missing',-1,'VEC') 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,'VEC') 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))) IF (SWPRI) WRITE (LIS2, 123) PATP 123 FORMAT ('0Peak profile: ', * 'for x.a = 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8'/ * 16X, 'shape = 1.000', 8F6.3 ) TAB(1) = 1. IXL = 0 I = 2 136 RRR = SQRT(FLOAT(I) - 0.9999) IX = RRR IF (IX.EQ.IXL) GOTO 137 IXL = IX TAB(I) = PATP(IX) IF (IX.EQ.7) GOTO 138 DELY = PATP(IX+1) - PATP(IX) DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY ) GOTO 138 137 DELX = RRR - FLOAT(IX) TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y 138 IF (TAB(I).GT.0.1) IMAX2 = I - 1 I = I + 1 IF (I.LE.50) GOTO 136 IF (IMAX2.GT.48) IMAX2=48 RMAX2 = FLOAT(IMAX2) / 100. VMAX = VVMAX + 1. V2MAX = VMAX**2 VMIN = 0.7 IF (NAT.GT.40) VMIN=1.7 V2MIN = VMIN**2 NMAXVE = 0 NVMAX = 0 NVE = 0 VMAXAT = 0.1 DO 350 J = 1, NAT-1 DO 350 K = J+1, NAT IF (NVE .EQ. MAXVE) THEN NMAXVE = NMAXVE + 1 GOTO 350 ENDIF VLEN2 = (ATXYZ(1,K) - ATXYZ(1,J))**2 * + (ATXYZ(2,K) - ATXYZ(2,J))**2 * + (ATXYZ(3,K) - ATXYZ(3,J))**2 IF (VLEN2 .GT. VMAXAT) VMAXAT = VLEN2 IF (VLEN2 .LT. V2MIN) GOTO 350 IF (VLEN2 .GT. V2MAX) THEN NVMAX = NVMAX + 1 GOTO 350 ENDIF NVE=NVE+1 VEX(NVE) = ATXYZ(1,K) - ATXYZ(1,J) VEY(NVE) = ATXYZ(2,K) - ATXYZ(2,J) VEZ(NVE) = ATXYZ(3,K) - ATXYZ(3,J) WI(NVE) = ATXYZ(4,J) * ATXYZ(4,K) W(NVE) = WI(NVE) VLEN(NVE) = SQRT(VLEN2) IF (NVE .EQ. 1) GOTO 350 DO 340 I = 1, NVE-1 IF (ABS (VLEN(NVE)-VLEN(I)) .GT. 0.1) GOTO 340 IF (ABS (VEX(NVE)-VEX(I)) .GT. 0.1) GOTO 335 IF (ABS (VEY(NVE)-VEY(I)) .GT. 0.1) GOTO 335 IF ( (VEX(NVE)-VEX(I))**2 + * (VEY(NVE)-VEY(I))**2 + * (VEZ(NVE)-VEZ(I))**2 .LE. 0.01) GOTO 338 335 IF (ABS (VEX(NVE)+VEX(I)) .GT. 0.1) GOTO 340 IF (ABS (VEY(NVE)+VEY(I)) .GT. 0.1) GOTO 340 IF ( (VEX(NVE)+VEX(I))**2 + * (VEY(NVE)+VEY(I))**2 + * (VEZ(NVE)+VEZ(I))**2 .GT. 0.01) GOTO 340 338 WI(I) = WI(I) + WI(NVE) W(I) = WI(I) NVE = NVE-1 GOTO 350 340 CONTINUE 350 CONTINUE IF (NMAXVE .GT. 0) WRITE (LIS1, '( * '' Storage problems: nr of vectors skipped:'', I6)') NMAXVE IF (NVMAX .GT. 0) WRITE (LIS1, '( * '' Number of very large vectors skipped: '', I4)') NVMAX WRITE (LIS1, FMT = '( * '' Number of different vectors generated: '', I4)') NVE VMAXAT = SQRT (VMAXAT) WRITE (LIS1, 354) VMAXAT 354 FORMAT (' Longest vector in the model is:',16X, F8.2) MF = NVE - 1 IF (MF.LE.0) GOTO 521 RMAX1 = SQRT (RMAX2) DO 520 MVEC = 1,MF DO 520 NVEC = MVEC+1, NVE IF (ABS (VLEN(NVEC) - VLEN(MVEC)) .GT. 0.7) GOTO 520 IF (ABS (VEX(NVEC) - VEX(MVEC)) .GT. RMAX1) GOTO 515 IF (ABS (VEY(NVEC) - VEY(MVEC)) .GT. RMAX1) GOTO 515 RR = (VEX(NVEC) - VEX(MVEC))**2 * + (VEY(NVEC) - VEY(MVEC))**2 * + (VEZ(NVEC) - VEZ(MVEC))**2 IF (RR .LE. RMAX2) GOTO 518 515 IF (ABS (VEX(NVEC) + VEX(MVEC)) .GT. RMAX1) GOTO 520 IF (ABS (VEY(NVEC) + VEY(MVEC)) .GT. RMAX1) GOTO 520 RR = (VEX(NVEC) + VEX(MVEC))**2 * + (VEY(NVEC) + VEY(MVEC))**2 * + (VEZ(NVEC) + VEZ(MVEC))**2 IF (RR .GT. RMAX2) GOTO 520 518 G = RR/DEL + 1. IG = G F = G - FLOAT(IG) OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F W(MVEC) = W(MVEC) + OVRLAP * WI(NVEC) W(NVEC) = W(NVEC) + OVRLAP * WI(MVEC) 520 CONTINUE 521 WTCUT = 3.6 VMAX = VMAX - 1. VMIN = 1.7 IF (NAT.LT.7) VMIN=0.7 JMAX = NVE NVE = 0 DO 620 J=1,JMAX IF (W(J).LE.WTCUT) GOTO 620 IF (VLEN(J).GT.VMAX) GOTO 620 IF (VLEN(J).LT.VMIN) GOTO 620 NVE = NVE + 1 VEX(NVE) = VEX(J) VEY(NVE) = VEY(J) VEZ(NVE) =VEZ(J) W(NVE)=W(J) WI(NVE)=WI(J) VLEN(NVE)=VLEN(J) IF(KWVLEN .GT. 1) W(J) = W(J) * VLEN(J) IF(KWVLEN .EQ. 1) W(J) = W(J) * SQRT(VLEN(J)) IW(NVE) = W(J) * 30. 620 CONTINUE IF (NIJM) WRITE (LIS1, FMT = '( * '' Number of independent vectors generated:'', I4)') NVE IF (NIJM) WRITE (LIS1, 622) VMIN, VMAX 622 FORMAT (' Vector length program limitations: ' , 7X, * F6.2, '-', F5.2 ) IF (NVE .LE. 0) CALL KERNER (992, 'VEC') CALL BSORT5 (IW, VEX, VEY, VEZ, VLEN, NVE) DO 630 J=1,NVE W(J) = FLOAT(IW(J)) / 30. IF(KWVLEN .GT. 1) W(J) = W(J) / VLEN(J) IF(KWVLEN .EQ. 1) W(J) = W(J) / SQRT(VLEN(J)) 630 CONTINUE IF (.NOT. SWPRI) GOTO 650 WRITE (LIS2, 632) 632 FORMAT (' List of VECTORS IN DESCENDING ORDER OF WEIGHTS') WRITE (LIS2, 670) DO 640 KDES=1,NVE K = NVE-KDES+1 640 WRITE (LIS2, 710) KDES, VEX(K), VEY(K), VEZ(K), W(K), VLEN(K) 650 SEPN = 0.4 SEPN2 = 0.16 IF (SWPRI) WRITE (LIS2, 660) SEPN 660 FORMAT (' Minimum vector separation is: ' ,F7.3) IF (SWPRI) WRITE (LIS2, 670) 670 FORMAT (/15X, 4HVECX,4X,4HVECY,4X, 22HVECZ WEIGHT LENGTH ) CALL KERNZI (0, KFLAG, NVE) VMAXAT = 0.1 N = NVE MAXV2 = MAXV NV = 0 700 IF (KFLAG(N) .NE. 0) GOTO 800 NV = NV + 1 VECTA(1, NV) = VEX(N) VECTA(2, NV) = VEY(N) VECTA(3, NV) = VEZ(N) VECTA(4, NV) = W(N) VECTA(5, NV) = VLEN(N) IF (VLEN(N).GT.VMAXAT) VMAXAT=VLEN(N) IF (SWPRI) * WRITE (LIS2, 710) NV, VEX(N), VEY(N), VEZ(N), W(N), VLEN(N) 710 FORMAT (' VECTOR', I4, 3F8.3, 2X, 2F8.3) IF (NV .EQ. MAXV2) GOTO 810 J=N-1 IF (J .EQ. 0) GOTO 810 720 IF (KFLAG(J).NE.0) GOTO 770 IF (ABS(VLEN(J) - VLEN(N)) .GE. SEPN) GOTO 770 IF ( (VEX(J)-VEX(N))**2 + (VEY(J)-VEY(N))**2 + (VEZ(J)-VEZ(N))**2 * .LT. SEPN2) GOTO 750 IF ( (VEX(J)+VEX(N))**2 + (VEY(J)+VEY(N))**2 + (VEZ(J)+VEZ(N))**2 * .GE. SEPN2) GOTO 770 750 KFLAG(J)=1 770 J=J-1 IF (J .NE. 0) GOTO 720 800 N=N-1 IF (N .GT. 0) GOTO 700 810 CONTINUE IF (NIJM) WRITE (LIS1, 953) NV 953 FORMAT (' Number of accepted vectors is:' , I14) NVECA = NV WRITE (LIS1, 954) VMAXAT 954 FORMAT (' Longest accepted vector is:', 20X, F8.2) VMAXAT = VMAXAT + 0.001 RETURN END SUBROUTINE BSORT5 (A, B, C, D, E, N) DIMENSION A(N),B(N),C(N),D(N),E(N) INTEGER A INTEGER DEL, BE, DE IF (N.LE.1) RETURN NA=N-1 DO 10 I=1,NA IF (A(I).LE.A(I+1)) GOTO 10 T=A(I) A(I)=A(I+1) A(I+1)=T T=B(I) B(I)=B(I+1) B(I+1)=T T=C(I) C(I)=C(I+1) C(I+1)=T T=D(I) D(I)=D(I+1) D(I+1)=T T=E(I) E(I)=E(I+1) E(I+1)=T 10 CONTINUE DEL=1 20 IF (DEL.GE.A(N)) GOTO 30 DEL=DEL+DEL GOTO 20 30 DEL=DEL/2 IF (DEL.EQ.0) RETURN BE=0 I=1 DE=DEL 50 IF (I.GE.N) GOTO 60 DO 70 L=I,N IF (A(L).GE.(DE+DEL)) GOTO 800 70 CONTINUE L=N GOTO 800 60 IF (BE.EQ.0) RETURN GOTO 30 800 IF (L.LE.(I+1)) GOTO 90 BE=1 J=L-1 85 IF (A(J)-DE) 100,110,110 90 I=L DE=DE+2*DEL GOTO 50 100 I=I+1 IF (I.GT.J) GOTO 90 IF (A(I-1).LT.DE) GOTO 100 T=A(I-1) A(I-1)=A(J) A(J)=T T=B(I-1) B(I-1)=B(J) B(J)=T T=C(I-1) C(I-1)=C(J) C(J)=T T=D(I-1) D(I-1)=D(J) D(J)=T T=E(I-1) E(I-1)=E(J) E(J)=T 110 J=J-1 IF (I-J) 85,90,85 END SUBROUTINE EULOUT COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IATOMS,IFILE(1)), (IATMOD, IFILE(2)) EQUIVALENCE (IATOLD,IFILE(10)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (LMINCM, KEYS(17)) LOGICAL XBIG EQUIVALENCE (XBIG, SWITCH(14)) 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 (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB PARAMETER (MAXAT = 1026) COMMON /ATODAT/ NAT, ATXYZ(10, MAXAT), IZAT(MAXAT) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER *6 ATNAME PARAMETER (M25 = 98) DIMENSION RR(3,3), VL(M25), SIG(M25), XMIN(3), RSYMM(3,3,24) LOGICAL LARGE DATA KSET / 0 / IF (LMINCM .GT. 0) THEN FOMOR = FLOAT(LMINCM) / 1800. WRITE (LIS1, 133) FOMOR 133 FORMAT (/' $$$ Fig. of Merit for best solution: FOMOR =', F7.4) LMINCH = KEYS(18) FOMOR = FLOAT(LMINCM) / 1800. WRITE (LIS1, 133) FOMOR ENDIF WRITE (LIS2, 140) WRITE (LIS1, 140) 140 FORMAT (/' Final list of Eulerian angles FOM=ISIG=100.pe', * 'ak/sigma'/ ' Set No. A B C ISIG '/) ISIGT = ISIG(1) * 5 / 10 - 1 DO 144 I = 1,NPKS IF (.NOT. XBIG .AND. I .EQ. 3) ISIGT = ISIG(1) * 7 / 10 - 1 IF ( XBIG .AND. I .EQ. 25) ISIGT = ISIG(1) * 7 / 10 - 1 IF (ISIG(I) .GT. ISIGT) KSET = I WRITE (LIS2, 145) I, APIK(I), BPIK(I), CPIK(I), ISIG(I) 144 WRITE (LIS1, 145) I, APIK(I), BPIK(I), CPIK(I), ISIG(I) 145 FORMAT (I6, 3F10.2, I8) IF (KSET .EQ. 0) CALL KERROR(' No results', 0, 'ORIENT') REWIND IATMOD CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) WRITE (CHOUT, 148) CCODE 148 FORMAT (' Output atomic parameters for ', A6, ' to file ATOMS') CALL SHOUT2 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3)) NIP = 1 WRITE (IATOMS, 149) CCODE, PROGNM, IT, KEYS(13), NIP, ISIG(NIP) 149 FORMAT ('ATOMS ', A6, ' from pgm ', * A8, ' date', I7, ' RUN', I4, ' OR=', I3, ' ISIG=', I5) WRITE (IATOMS,150) NIP, APIK(NIP), BPIK(NIP), CPIK(NIP), ISIG(NIP) 150 FORMAT ('REMARK xxx atom set',I3,': ABC =',3F7.2,' ISIG =',I5) KSETM = 20 IF (XBIG) KSETM = 37 KSET = MIN0 (KSETM, KSET) WRITE (CHOUT, 160) KSET 160 FORMAT (' Atom calculation will be called for the following', * I3, ' ABC peaks') CALL SHOUT2 LARGE = .FALSE. IF (NAT .GT. M25) LARGE = .TRUE. IF (LARGE) GOTO 200 DO 180 I = 1, NAT 180 VL(I) = SQRT (ATXYZ(1,I)**2 + ATXYZ(2,I)**2 + ATXYZ(3,I)**2) CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM) 200 KAL = 0 DO 500 IP = 1, KSET IF (NAT + KAL * NAT + NAT .GT. MAXAT) THEN WRITE (LIS1, 201) 201 FORMAT (/' Remaining possible orientations rejected...'/) GOTO 501 ENDIF CALL MATABC (APIK(IP), BPIK(IP), CPIK(IP), RR) DO 210 I = 1,NAT CALL MATXV3 (RR, ATXYZ(1,I), ATXYZ(5,I)) 210 CALL MAT6XV (CART2F, ATXYZ(5,I), ATXYZ(8,I)) IF (LARGE) GOTO 400 SIGT = 1.18 * ISIG(IP) IF (XBIG) SIGT = 1.05 * ISIG(IP) IF (KAL .EQ. 0) GOTO 400 DO 350 ISYMM = 1, NSYMM L = NAT + KAL * NAT + 1 DO 240 I = 1, NAT CALL MATXV3 (RSYMM(1,1,ISYMM), ATXYZ(8,I), ATXYZ(1,L)) 240 L = L + 1 DO 300 KA = 1, KAL IF (SIG(KA) .GT. SIGT) GOTO 300 L = NAT + KAL * NAT + 1 ESD = 0.0001 ESDM = 0.0001 NESD = 0 DO 270 I = 1, NAT K = KA * NAT + 1 DO 260 J = 1, NAT IF (IZAT(I) .NE. IZAT(J)) GOTO 260 IF (ABS (VL(I) - VL(J)) .GT. 0.3) GOTO 260 DMAX = 0.3 CALL DISTSQ (ATXYZ(1,K), ATXYZ(1,L), DMAX, XMIN, DIST2) IF (DIST2 .GT. 99.) GOTO 260 ESDM = AMAX1 (ESDM, DIST2) NESD = NESD + 1 ESD = ESD + DIST2 GOTO 270 260 K = K + 1 GOTO 300 270 L = L + 1 ESD = SQRT (ESD / NAT) ESDM = SQRT (ESDM) IF (NESD .NE. NAT) CALL KERROR ('MOD 95 fout !', 0, 'EULOUT') WRITE (LIS1, 272) IP, KA, ESD, ESDM WRITE (LIS2, 272) IP, KA, ESD, ESDM 272 FORMAT (/' Set No.',I3,' gives the same atoms as set No.', I3/ * 11X, ' with esd of interatomic distances =' , F5.2, ' Angstrom'/ * 11X, ' and largest interatomic deviation =' , F5.2, ' Angstrom') GOTO 500 300 CONTINUE 350 CONTINUE 400 KAL = KAL + 1 SIG(KAL) = ISIG(IP) WRITE (CHOUT, 402) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP) 402 FORMAT ('0Set No.', I3,' (ABC =',3F7.2,') with ISIG=', I4) CALL SHOUT2 IF (KAL .EQ. 1) THEN WRITE (LIS1, 417) 417 FORMAT (/' Atomic coordinates (x,y,z)', * ' written to ATOMS file:'/ * ' nr. at.name', 9X, 'x', 8X, 'y', 8X, 'z' ) DO 420 I = 1, NAT WRITE (LIS1, 422) I, ATNAME(I), (ATXYZ(J,I), J = 8,10) 420 WRITE (IATOMS, 423) ATNAME(I), (ATXYZ(J,I), J = 8,10) 422 FORMAT (I6, 3X, A6, 2X, 3F9.5) 423 FORMAT ('ATOM', 3X, A6, 2X, 3F9.5) WRITE (IATOMS, FMT='(''END'')') ENDIF L = KAL * NAT + 1 WRITE (LIS2, 426) 426 FORMAT (/ 8X, 'atom', 8X, 'Cartesian', 15X, 'fractional' / * 8X, 'name', 8X,'X',6X,'Y',6X,'Z',9X,'X',8X,'Y',8X,'Z') IF (KAL .GE. 2 .AND. .NOT. LARGE) THEN NIP = NIP + 1 WRITE (IATOMS, 149) CCODE, PROGNM, IT, KEYS(13), NIP, ISIG(IP) WRITE (IATOMS, 150) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP) ENDIF DO 430 I = 1, NAT IF (.NOT. LARGE) CALL KERNAB (ATXYZ(8,I), ATXYZ(1,L), 3) WRITE (LIS2, 428) ATNAME(I), (ATXYZ(J,I), J = 5, 10) 428 FORMAT (' ATOM', 2X, A6, 2X, 3F7.3, 4X, 3F9.5) IF (KAL .GE. 2 .AND. .NOT. LARGE) * WRITE (IATOMS, 423) ATNAME(I), (ATXYZ(J,I), J = 8,10) 430 L = L + 1 IF (KAL .GE. 2 .AND. .NOT. LARGE) WRITE (IATOMS, FMT='(''END'')') 500 CONTINUE 501 CONTINUE IF (KAL .EQ. 1) THEN WRITE (LIS1, 503) WRITE (LIS2, 503) 503 FORMAT (/ ' Atom set 1 is the only acceptable result of ORIENT.'/ * ' The parameter set is transferred to TRACOR,' / * ' A copy of the parameter set is written to the ATOLD file.' ) ELSE WRITE (LIS1, 510) WRITE (LIS2, 510) 510 FORMAT (/ * ' The first accepted parameter set is transferred to TRACOR.' / * ' All accepted parameter sets are written to the ATOLD file,' / * ' for use in case the first set does not lead to the correct'/ * ' structure.' ) WRITE (LIS2, 511) 511 FORMAT ( * ' Note:' / * ' All accepted parameter sets are written to the ATOMS file,' / * ' but DDMAIN + TRACOR are going to use only the first set.') ENDIF WRITE (IATOMS, FMT= '(''FINISH'')') CALL FILCLO (IATMOD, 'KEEP') CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL FILCLO (IATOMS, 'KEEP') RETURN END SUBROUTINE MATABC (AE, BE, CE, R) DIMENSION R(3,3) DATA D2R /0.01745329252/ CA = COS (AE * D2R) CB = COS (BE * D2R) CC = COS (CE * D2R) SA = SIN (AE * D2R) SB = SIN (BE * D2R) SC = SIN (CE * D2R) CALL MATEUL (CA, CB, CC, SA, SB, SC, R) RETURN END SUBROUTINE MATEUL (CA, CB, CC, SA, SB, SC, R) DIMENSION R(3,3) R(1,1) = CB R(1,2) = SB * SC R(1,3) = -SB * CC R(2,1) = SA * SB R(2,2) = CA * CC - SA * CB * SC R(2,3) = SA * CB * CC + CA * SC R(3,1) = CA * SB R(3,2) =-CA * CB * SC - SA * CC R(3,3) = CA * CB * CC - SA * SC RETURN END SUBROUTINE MORV 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 SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) 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)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IMFUN, IFILE(13)) EQUIVALENCE (NRUN, KEYS(5)), (ITPL, KEYS(7)) LOGICAL NIJM EQUIVALENCE (NIJM, SWITCH(1)) 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 (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3), VMAXDE PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) EQUIVALENCE (ALPH,COSA),(BET,COSB),(GAMM,COSC) DATA FACM / 1.0/ NRUN = NRUN + 1 WRITE (LIS1, FMT = '(65X,''Cycle'', I2)') NRUN WRITE (LIS2, FMT = '(65X,''Cycle'', I2)') NRUN CALL KERNZA (0., AAA, 3) CALL KERNZA (0., SSS, 3) NPOINT = 0 IF (NRUN .EQ. 1) THEN CALL FILINQ (IMFUN, 'MFUN', 'UNFORMATTED', 'OUTPUT', KINQ) ITPL=1 IF (MPAR.GT.0) ITPL=2 ENDIF ITPL = MIN0 (8, ITPL * 2) IF (ITPL .NE. 2) THEN WRITE (CHOUT, FMT = '('' Patterson function retrieval:'', * I2, ''-point interpolation'') ') ITPL CALL SHOUT ELSE WRITE (CHOUT, FMT = '('' Patterson function retrieval:'', * '' max. of 8 neighbours'') ') CALL SHOUT ENDIF VMAXXX = 0. YZMAX= 0. VECMAX = VMAXDE IF (VMAXIN .GT. 0.1) THEN VMAXIN = AMIN1 (VMAXIN, VMAXDE) VECMAX = AMIN1 (VMAXIN, VECMAX) ENDIF IF (MPARIN .LE. 0) THEN IF (NRUN .EQ. 1) VECMAX = AMIN1 (4.6, VECMAX) IF (NRUN .EQ. 2) VECMAX = AMIN1 (6.2, VECMAX) IF (NRUN .EQ. 3 .AND. VECMAX .GT. 7.5) * VECMAX = AMAX1 (7.5, 0.5* (6.2 + VECMAX)) ENDIF IF (VMAXAT .GT. VECMAX) WRITE (LIS2, FMT = '( * '' Max. vector length to be used:'', 9X, F5.2 ) ' ) VECMAX NVECB = 0 DO 205 N = 1, NVECA IF (VECTA(5,N) .GT. VECMAX) GOTO 205 IF (VECTA(5,N) .GT. VMAXXX) VMAXXX = VECTA(5,N) YZ = VECTA(2,N)**2 + VECTA(3,N)**2 IF (YZ .GT. YZMAX) YZMAX = YZ NVECB = NVECB + 1 CALL KERNAB (VECTA(1,N), VECTB(1,NVECB), 4) 205 CONTINUE IF (NVECB .EQ. 0) CALL KERROR * ('All vectors too long; use larger VMAX', 205, 'MORV') WRITE (LIS1, FMT = '('' Nr of vectors and Max vector length:'', * 5X, I3, F11.2 ) ' ) NVECB, VMAXXX YZMAX = SQRT(YZMAX) IF (NVECB .LT. NVECA) WRITE (LIS2, FMT = * '('' Selected number of vectors:'', I17 ) ') NVECB IF (VMAXXX .LT. VECMAX -0.001) THEN WRITE (LIS2, FMT = * '('' Longest vector selected ='', 13X, F6.2) ') VMAXXX IF (YZMAX .GT. 0.00001) WRITE(LIS2, FMT = '( * '' Longest yz-component ='', 16X, F6.2)' ) YZMAX ENDIF IF (NRUN .EQ. 1 .AND. MININ .GT. 0) * FACM = AMIN1(1.8, FLOAT(MINM(MININ))/(0.5 * FLOAT(NVECB)) ) IF (MININ .GT. 0) CALL KERNAI (MINM, MM, MININ) IF (NRUN .GT. 1 .AND. MININ .GT. 0) THEN MM(MININ) = NINT (FACM * 0.5 * FLOAT(NVECB) +1. ) IF (MININ .GT. 1) MM(1) = NINT (FACM * 0.4 * FLOAT(NVECB) +1. ) IF (MININ .EQ. 3) MM(2) = NINT (FACM * 0.45* FLOAT(NVECB) +1. ) ENDIF IF (NRUN .EQ. 2 .AND. MININ .GT. 0) THEN MM(MININ) = MIN0 (MM(MININ), 2*MINM(MININ)) IF (MININ .GT. 1) MM(1) = MIN0 (MM(1), 2*MINM(1)) IF (MININ .EQ. 3) MM(2) = MIN0 (MM(2), 2*MINM(2)) ENDIF IF (MM(1).GT.0 .AND. MININ.GT.0) GOTO 122 IF (MIN4(1) .GT. 0) THEN MM(1) = MIN4(NRUN) GOTO 122 ENDIF IF (FVMIN .GT. 0.) THEN MM(1) = FVMIN * FLOAT(NVECB) + 1.0 GOTO 122 ENDIF MM(1) = 1 + NVECB/4 MM(2) = 2 + (NVECB-1)/3 + IABS(NVECB-6)/6 MM(3) = 2 + (NVECB-1)/2 IF (NVECB .EQ. 1) MM(2) = 0 IF (NVECB .LE. 4) MM(3) = 0 IF (NVECB .GT. 15) MM(2) = (MM(1) + MM(3)) / 2 122 CONTINUE MMM = 0 DO 158 J=1, 3 IF (MM(J).LE.0) GOTO 159 MMM = MMM + 1 IF (MM(J) .LE. NVECB) GOTO 154 WRITE (LIS2,153) 153 FORMAT (' MIN(M): M GREATER THEN NUMBER OF VECTORS. RESET.' /) MM(J) = NVECB 154 IF (MM(J) .EQ. NVECB) GOTO 159 158 CONTINUE 159 WRITE (LIS2,160) NRUN, (MM(J),J=1,MMM) 160 FORMAT (' Cycle', I2, '. Calculation of MIN(M), where M =', 3I4) IF (NIJM) WRITE (LIS1, 160) NRUN, (MM(J),J=1,MMM) IF (MPAR.EQ.0) CALL PARAMS WRITE (LIS2, 202) MPAR 202 FORMAT (' Number of sets of parameters generated (MPAR):', I5) IF (NIJM) WRITE (LIS1, * FMT='('' NIJM: Number of ABS-scans: MPAR='', I3)') MPAR IF (MPAR.GE.20) THEN WRITE (IPR1, FMT='('' Number of ABS-scans: MPAR='', I3)') MPAR ENDIF DO 300 IPAR = 1, MPAR I = MOD(IPAR, 20) IF (I .EQ. 0) * WRITE (IPR1, FMT='('' ... next: ABS-scan number:'', I3)') IPAR 300 CALL ORV (IPAR) TEMP = 0. DO 500 I=1, MMM AAA(I) = AAA(I) / FLOAT(NPOINT) TEMP = TEMP + AAA(I) SSS(I) = SSS(I) / FLOAT(NPOINT) SSS(I)= SQRT(SSS(I) - AAA(I)**2) 500 IF (SSS(I) .LE. 1.0) SSS(I) = 1.0 WRITE (LIS2, FMT ='('' Averages and sigmas for this cycle'' / * '' Min(m) average sigma for'', I6, '' points:'') ') NPOINT WRITE (LIS2, 504) (MM(J), AAA(J), SSS(J), J = 1,MMM) 504 FORMAT (I6, 2F9.2) IF (TEMP.LE.0.001) CALL KERROR (' Min fun map all zeros', * 500, 'MORV') IF (MPARIN .EQ. 0 .AND. NRUN .LE. 2) RETURN DO 600 I = 1, MMM SSS(I) = AAA(I) / 3. 600 AAA(I) = 0. RETURN END SUBROUTINE ORV (IPAR) 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 (IMFUN, IFILE(13)) EQUIVALENCE (NRUN, KEYS(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) PARAMETER (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R PARAMETER (IJK = 10 * MAXV + 1) DIMENSION CAX(IJK), CAY(IJK), CAZ(IJK), W(IJK), * ABX(IJK), ABY(IJK), ABZ(IJK), WVEPAT(IJK), VEPAT(IJK) EQUIVALENCE (CAX(1),VECTB(1,1)), (CAY(1),CAX(2)), (CAZ(1),CAX(3)), * (W(1),VECTB(4,1)), * (ABX(1),VECTB(6,1)), (ABY(1),ABX(2)), (ABZ(1),ABX(3)), * (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1)) PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DIMENSION ARG(3) DIMENSION RTM(3,3), XCRM(3,3), ABM(3,3), ROTM(3,3) LOGICAL BLOK DATA NVC /0/ BLOK = .FALSE. IF (NRUN .GE. 3) BLOK = .TRUE. IF (IPAR .EQ. 1) THEN REWIND IMFUN NVC = NVECB * 10 -9 ENDIF AI = PAR1(1,IPAR) BI = PAR1(2,IPAR) CI = PAR1(3,IPAR) AD = PAR2(1,IPAR) BD = PAR2(2,IPAR) CD = PAR2(3,IPAR) NA = NPAR(1,IPAR) NB = NPAR(2,IPAR) NC = NPAR(3,IPAR) IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) BLOK = .FALSE. IF (NC .GT. 65) CALL KERROR ('Nr.points C rot > 65 ', 0, 'ORV') NPOINT = NPOINT + NA * NB * NC WRITE (IMFUN) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC AI = PAR1(1,IPAR) * D2R BI = PAR1(2,IPAR) * D2R CI = PAR1(3,IPAR) * D2R AD = PAR2(1,IPAR) * D2R BD = PAR2(2,IPAR) * D2R CD = PAR2(3,IPAR) * D2R A=AI N1 = 1 GOTO 200 190 A=A+AD N1 = N1 + 1 IF (N1 .GT. NA) RETURN 200 SINA=SIN(A) COSA=COS(A) B=BI N2 = 1 GOTO 300 290 B=B+BD N2 = N2 + 1 IF (N2 .GT. NB) GOTO 190 300 SINB=SIN(B) COSB=COS(B) N3C = 1 C = CI SINC = SIN(C -CD) COSC = COS(C -CD) CALL MATEUL (COSA, COSB, COSC, SINA, SINB, SINC, ROTM) CALL MATMPY (CART2F, ROTM, ABM) DO 310 I = 1, NVECB 310 CALL MATXV3 (ABM, VECTB(1,I), VECTB(6,I)) CALL ROTMTX (CD, COSB, SINB*SINA, SINB*COSA, ROTM) CALL MATMPY (ROTM, FRAC2C, XCRM) CALL MATMPY (CART2F, XCRM, RTM) GOTO 400 390 C=C+CD N3C = N3C + 1 IF (N3C .GT. NC) GOTO 700 400 IVEC = 0 DO 480 IVE=1,NVC,10 IVEC = IVEC + 1 CALL MATXV3 (RTM, VECTB(6,IVEC), ARG) CALL KERNAB (ARG, VECTB(6,IVEC), 3) CALL RDOUT(ARG,PATF) WVEPAT (IVE)=PATF/W(IVE) VEPAT(IVE)=PATF 480 CONTINUE CALL ISF (NVC, N3C) GOTO 390 700 WRITE (IMFUN) NC, MMM, ((LMINC(K,N),K=1,NC), N=1,MMM) DO 795 J = 1, MMM ITOTAL = 0 ISUMSQ = 0 DO 792 K=1,NC ITOTAL = ITOTAL + LMINC(K,J) 792 ISUMSQ = ISUMSQ + LMINC(K,J)**2 AAA(J) = AAA(J) + FLOAT(ITOTAL) 795 SSS(J) = SSS(J) + FLOAT(ISUMSQ) GOTO 290 END SUBROUTINE ISF (NVEC, N3C) PARAMETER (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R PARAMETER (IJK = 10 * MAXV + 1) DIMENSION W(IJK), WVEPAT(IJK), VEPAT(IJK) EQUIVALENCE (W(1),VECTB(4,1)), * (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1)) PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DIMENSION LOW(MAXV), SAVP(MAXV) DATA LO /0/ SUMP=0. SUMW=0. MLARGE = MM(MMM) DO 770 J=1,MLARGE WPLOW=999999. DO 760 K=1,NVEC,10 IF (WVEPAT(K).GE.WPLOW) GOTO 760 LO=K WPLOW=WVEPAT(K) 760 CONTINUE SAVP(J)=WPLOW LOW(J)=LO 770 WVEPAT(LO)=999999. K=1 DO 800 J=1,MLARGE L=LOW(J) WVEPAT(L)=SAVP(J) SUMP=SUMP+VEPAT(L) SUMW=SUMW+W(L) IF (J .NE. MM(K)) GOTO 800 LMINC(N3C,K) = 1800. * SUMP / SUMW K=K+1 800 CONTINUE RETURN END SUBROUTINE PARAMS 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 (KLAUE, KEYS(6)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXV = 234) COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV), * VDUMM(10), VMAXIN, VMAXAT, D2R PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) WRITE (LIS2, FMT = '('' Generate scan params. for ORV'' ) ') ISPAR = 0 CI = 5. CD = 10. NC = CMAX / 9.9 IF (NVECA .EQ. 1) NC = 1 BI = 0. NB = 1 IF (KLAUE.EQ.1) NB=2 AI = 0. AD = 60. NA = 1 I = 1 100 BD = 180. - BI - BI 111 ISPAR = ISPAR + 1 MPAR = I PAR1(1,I) = AI PAR2(1,I) = AD NPAR(1,I) = NA PAR1(2,I) = BI PAR2(2,I) = BD NPAR(2,I) = NB PAR1(3,I) = CI PAR2(3,I) = CD NPAR(3,I) = NC I = I + 1 GOTO (100 ,2, 3, 33, 4, 5, 6, 7, 8, 9), I 2 BI = 9. AI = 30. NA = 6 IF (KLAUE.EQ.3) NA = 3 GOTO 100 3 BI = 16. AI = 0. GOTO 100 33 BI = 22. AI = 30. GOTO 100 4 BI = 26. AI = 15. AD = 30. NA = NA * 2 GOTO 100 5 BI = 33. AI = 0. GOTO 100 6 BI = 40. AI = 7.5 AD = 15. NA = NA * 2 GOTO 100 7 BI = 50. AI = 0. GOTO 100 8 AI = 5. AD = 10. NA = (NA * 3) / 2 BI = 60 NB = 4 IF (KLAUE.EQ.1) NB=7 BD = 10. GOTO 111 9 RETURN END SUBROUTINE ROTMTX (ROT, DCOS1, DCOS2, DCOS3, ROTM) DIMENSION ROTM(3,3) COSR = COS(ROT) COS1 = COSR-1. SINR = SIN(ROT) T = DCOS1 * COS1 ROTM(1,1) = COSR - DCOS1 * T T1 = DCOS2*SINR T2 = DCOS3*SINR T3 = -DCOS2*T ROTM(1,2) = T3 + T2 ROTM(2,1) = T3 - T2 T3 = -T * DCOS3 ROTM(3,1) = T3 + T1 ROTM(1,3) = T3 - T1 ROTM(2,2) = COSR - DCOS2 * DCOS2 * COS1 T1 = DCOS1 * SINR T3 = -DCOS2 * COS1 * DCOS3 ROTM(2,3) = T3 + T1 ROTM(3,2) = T3 - T1 ROTM(3,3) = COSR - DCOS3 * DCOS3 * COS1 RETURN END SUBROUTINE MATMPY (RM1,RM2,RM3) DIMENSION RM1(3,3),RM2(3,3),RM3(3,3) DO 150 J=1,3 DO 150 K=1,3 RM3(J,K)=0. DO 150 L=1,3 150 RM3(J,K)=RM3(J,K)+RM1(J,L)*RM2(L,K) RETURN END SUBROUTINE MAPSIG 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)) EQUIVALENCE (IMFUN, IFILE(13)), (IPRSIG, KEYS(10)) EQUIVALENCE (LMINCM, KEYS(17)) EQUIVALENCE (NRUN, KEYS(5)) LOGICAL NIJM, SWPRI EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DIMENSION CLABL(65), LISIG(65,3) EQUIVALENCE (LISIG(1,1), LMINC(1,1)) LOGICAL NIJA, BLOK BLOK = .FALSE. NIJA = NIJM .AND. NRUN.GE.4 .AND. .NOT.SWPRI .AND. IPRSIG.LE.0 INIT65 = 0 NREP = 0 REWIND IMFUN IF (IPRSIG .GT. 0) THEN WRITE (CHOUT, FMT='('' Write MAPSIG min fun to printer LIS2'')') CALL SHOUT2 WRITE (LIS2, 102) NRUN, TITLE 102 FORMAT (' MAPSIG MIN. FUNCTIONS cycle', I2, ' TITLE = ', A64 /) ENDIF IMIN = 0 IF (NRUN.GT.1) GOTO 135 IF (MPARIN.LE.0) THEN IMIN = 200 ENDIF IF (NPOINT .LT. 1000) IMIN = NPOINT / 20 SIGOUT = FLOAT (IMIN) / 100. WRITE (LIS2, 131) SIGOUT, IMIN 131 FORMAT (' Output ABC points:' / * ' Function values of the minimun function are output' / * ' if SIGOUT (= function value / sigma) is at least:', F6.2 / * ' ISIG (= 100 * SIGOUT) is used as a figure of merit' / * ' The minimum value (=ISIGmin) for the first run is:', I6 ) IF (IPRSIG .GT. 0) WRITE (CHOUT, 132) 132 FORMAT (' Printing of min fun maps (skip insignificant lines)'/) CALL SHOUT2 135 CONTINUE ISIGM = 0 NPKS = 0 DO 990 KPAR = 1, MPAR VMINCH = 0. READ (IMFUN, END=990) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC IPARAV(IPAR) = 0 IF (KPAR .NE. IPAR) WRITE (LIS1, FMT='('' ??? KPAR/IPAR ???'')') MMM3 = MMM IF (IPAR .EQ. 1 .AND. SWPRI) THEN WRITE (LIS2, FMT = '(/'' Scan parameters'' / * '' Set No. Ainit Aincr N'', 5X, * ''Binit Bincr N'', 5X,''Cinit Cincr N'' /)') ENDIF IF (SWPRI) WRITE (LIS2, FMT = '(I5, 5X, 3(2F7.2, I6, 3X) )') * IPAR, AI, AD, NA, BI, BD, NB, CI, CD, NC IF (IPRSIG .GT. 0) THEN CC = CI - CD DO 700 I=1, NC CC = CC + CD 700 CLABL(I) = CC WRITE (LIS2, 748) IPAR, (CLABL(I), I=1,NC) 748 FORMAT (' Parameter set no. ', I3 / * ' A B MIN(M) MAX C=',1 9F5.0 / (30X, 19F5.0)) ENDIF IF (NRUN .GE. 3) BLOK = .TRUE. IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) BLOK = .FALSE. IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) NIJA = .FALSE. IF (NIJA) THEN CC2 = CI + CD CC3 = CC2 + CD CC4 = CC3 + CD WRITE (LIS1, '(/'' parameter set no.'', I3, '' C='', * 4F6.1 )') KPAR, CI, CC2, CC3, CC4 ENDIF AA = AI - AD DO 980 IA=1,NA AA = AA + AD IF (NIJA) WRITE (LIS1, FMT='(/'' A='',F5.1, * 3(6X, ''MIN(M): M='',I3) )') AA, (MM(J),J=1,MMM) BB = BI - BD DO 980 IB=1,NB BB = BB + BD READ (IMFUN) NC, MMM, ((LMINC(K,J), K=1,NC), J=1,MMM) IF (NIJA) WRITE (LIS1, FMT='('' B='',F5.1, 3 (3X,4I4))') * BB, ((LMINC(K,J), K=1,NC), J=1,MMM) IF (BLOK) THEN IPARAV(IPAR) = IPARAV(IPAR) + * LMINC(1,1) + LMINC(2,1) + LMINC(3,1) + LMINC(4,1) IF (IA.EQ.4 .AND. IB.EQ.4) IPARAV(IPAR) = IPARAV(IPAR)/64 IF (NIJM .AND. IA.EQ.4 .AND. IB.EQ.4) WRITE (LIS1, FMT='( * '' TEMP NIJM average LMINC for IPAR:'', 2I6)') * IPARAV(IPAR), IPAR ENDIF IMAXJ = 0 DO 800 J=1, MMM DO 800 I=1, NC V = LMINC(I,J) IV = 100.1 * (V - AAA(J)) / SSS(J) LISIG(I,J) = MAX0 (0, IV) IF (J .EQ. 1) THEN VMINCH = AMAX1(VMINCH, V) KEYS(18) = NINT (VMINCH) IMAXJ = MAX0 (IMAXJ, IV) ENDIF 800 CONTINUE IF (IMAXJ .LT. IMIN) GOTO 980 IF (IMAXJ .LT. ISIGM) GOTO 862 ISIGM = IMAXJ IMIN = MAX0 (IMIN, ISIGM / 2) 862 IF (IPRSIG .LE. 0) GOTO 950 DO 909 J=1,MMM 907 FORMAT (2F6.1, 2I6, 6X, 19I5 / (30X, 19I5)) 909 WRITE (LIS2, 907) AA, BB, MM(J), IMAXJ, (LISIG(I,J), I=1,NC) 950 CC = CI - CD DO 974 IC = 1, NC CC = CC + CD IF (LISIG(IC,1) .LT. IMIN) GOTO 974 NPKS = NPKS + 1 APIK(NPKS) = AA BPIK(NPKS) = BB CPIK(NPKS) = CC ISIG(NPKS) = LISIG(IC,1) DO 972 JSIG = 1, MMM 972 ISIG3(NPKS,JSIG) = LISIG(IC,JSIG) NPIK(NPKS) = IPAR IF (NRUN .EQ. 4) THEN IJ = NINT ( AAA(MMM) + SSS(MMM) * FLOAT(LISIG(IC,MMM))/ 100.1 ) IF (IJ .GT. LMINCM) LMINCM = IJ ENDIF 974 CONTINUE IF (NPKS .LT. MAXPK-65) GOTO 980 INIT65 = 0 IF (NIJM) WRITE (LIS1, FMT= * '('' $$$7 TEMP increase IMIN? Old value:'', I5)') IMIN 975 INIT65 = INIT65 + 1 IF (INIT65 .GE. 2) IMIN = 11*IMIN/10 IF (INIT65 .GE. 2 .AND. NIJM) WRITE (LIS1, FMT= * '('' $$$7 TEMP increase IMIN: new value='', I5)') IMIN N = 0 DO 978 I = 1, NPKS IF (ISIG(I) .LT. IMIN) GOTO 978 N = N + 1 APIK(N) = APIK(I) BPIK(N) = BPIK(I) CPIK(N) = CPIK(I) ISIG(N) = ISIG(I) DO 977 JSIG = 1, MMM 977 ISIG3(N,JSIG) = ISIG3(I,JSIG) NPIK(N) = NPIK(I) 978 CONTINUE NPKS = N IF (NPKS .GE. MAXPK-65) GOTO 975 980 CONTINUE 990 CONTINUE WRITE (LIS2, 992) NPKS, NPOINT 992 FORMAT (' $$$2 Nr of ABC min-fun points selected:', I4, * ' (out of', I5, ' points)') IF (NIJM) WRITE (LIS1, 992) NPKS, NPOINT MPAR = 0 IF (NIJA) WRITE (LIS1, '( * /'' parameter sets to be printed will be reordered !'')') RETURN END SUBROUTINE REGION 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 (KLAUE, KEYS(6)) LOGICAL SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) LOGICAL XBIG EQUIVALENCE (XBIG, SWITCH(14)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION LFL(MAXPK) EQUIVALENCE (LFL(1),NPIK(1)) PARAMETER (MXPA = 100) DIMENSION * AF(MXPA), BF(MXPA), CF(MXPA), AT(MXPA), BT(MXPA), CT(MXPA), * NPT(MXPA), MAXSIG(MXPA), NUMA(MXPA), NUMB(MXPA), NUMC(MXPA) PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DATA DEA,DEB,DEC /10.,10.,10./ DATA MSIGFR /4/ DATA ISAVE /0/ DELAB = 12. DELCA = 12. IF (XBIG) THEN DELAB = 9. DELCA = 9. DELC = 7. ENDIF CALL RDMAPS (MSIGFR, NP) AMAX = 360. IF (KLAUE.EQ.3) AMAX = 180. NP2 = 0 DO 10 I=1,NP IF (ABS(BPIK(I)).GT.23. .AND. ABS(180.-BPIK(I)).GT.23.) GOTO 10 ISIG(I) = ISIG(I) - 9999 NP2 = NP2 + 1 10 CONTINUE IF (NP2.GT.0) CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP) NP = NP - NP2 CALL KERNZI (0, MAXSIG, MXPA) CALL KERNZI (0, NPT, MXPA) CALL KERNZI (0, LFL, MAXPK) IF (NP.EQ.0) GOTO 830 NR=0 NPTOT = 0 CALL NEBOR (0, NP, DELAB, DELCA, IANSW) DO 800 IP=1,NP IF(LFL(IP).NE.0) GOTO 800 IF (NR.GE.50) GOTO 805 IF (NR.GE.20 .AND. NPTOT.GT.400) GOTO 805 NR=NR+1 LFL(IP)=NR NPT(NR)=1 AF(NR)=APIK(IP) AT(NR)=APIK(IP) BF(NR)=BPIK(IP) BT(NR)=BPIK(IP) CF(NR)=CPIK(IP) CT(NR)=CPIK(IP) MAXSIG(NR)=ISIG(IP) IF(IP.EQ.NP) GOTO 800 L=IP+1 ISW = 1 DO 700 I=IP,NP IF (LFL(I).NE.NR) GOTO 700 DO 300 NB=L,NP IF (NB.EQ.I) GOTO 300 IF (LFL(NB).NE.0) GOTO 300 CALL NEBOR (I, NB, DELAB, DELCA, IANSW) IF(IANSW.EQ.0) GOTO 300 LFL(NB) = ISW * NR IF (APIK(NB).GT.AT(NR)) AT(NR)=APIK(NB) IF (APIK(NB).LT.AF(NR)) AF(NR)=APIK(NB) IF (BPIK(NB).GT.BT(NR)) BT(NR)=BPIK(NB) IF (BPIK(NB).LT.BF(NR)) BF(NR)=BPIK(NB) IF (CPIK(NB).GT.CT(NR)) CT(NR)=CPIK(NB) IF (CPIK(NB).LT.CF(NR)) CF(NR)=CPIK(NB) NPT(NR) = NPT(NR)+1 NPTOT = NPTOT + 1 300 CONTINUE 700 ISW = -1 DO 740 I=L,NP IF (LFL(I).LT.0) LFL(I)=-LFL(I) IF (LFL(I).NE.0) GOTO 740 IF (APIK(I).LT.AF(NR) .OR. APIK(I).GT.AT(NR)) GOTO 740 IF (BPIK(I).LT.BF(NR) .OR. BPIK(I).GT.BT(NR)) GOTO 740 IF (CPIK(I).LT.CF(NR) .OR. CPIK(I).GT.CT(NR)) GOTO 740 LFL(I) = NR NPT(NR) = NPT(NR)+1 NPTOT = NPTOT + 1 740 CONTINUE 800 CONTINUE 805 CONTINUE DELA=DEA/2. DELB=DEB/2. DELC=DEC/2. WRITE (LIS2, 808) DELA,DELB,DELC 808 FORMAT ('0Prepare new scan parameters for next cycle'/ * ' ABC-increments for regions:', 3F6.2) IF (SWPRI) WRITE (LIS2, FMT = '(''0Nr. max. Nr.points to be''/ * '' pts ISIG searched for in this region''/ * '' ---- ---- ---'')') DO 810 IR=1,NR AF(IR)=AF(IR)-DELA BF(IR)=BF(IR)-DELB CF(IR)=CF(IR)-DELC NUMA(IR)=ABS(AT(IR)-AF(IR))/DELA+2.1 NUMB(IR)=ABS(BT(IR)-BF(IR))/DELB+2.1 NUMC(IR)=ABS(CT(IR)-CF(IR))/DELC+2.1 I = NUMA(IR) * NUMB(IR) * NUMC(IR) CALL STOPAR (AF(IR), BF(IR), CF(IR), * NUMA(IR), NUMB(IR), NUMC(IR), MAXSIG(IR)) 810 IF (SWPRI) WRITE (LIS2, 820) NPT(IR), MAXSIG(IR), I 820 FORMAT (3I5) WRITE (LIS2, 822) (MAXSIG(IR), IR = 1, NR) 822 FORMAT (' Maximum ISIG found in regions: ', 10I4 / (32X, 10I4)) 830 IF (NP2.EQ.0) GOTO 950 IF (NP .EQ. 0) THEN WRITE (LIS2, 822) WRITE (LIS2, FMT='('' ... only polar regions found:'')') ELSE WRITE (LIS2, FMT='('' ... and for polar regions... '')') ENDIF NPTOT = 0 DELB = 2. DELC = 4. DO 849 I=1,NP2 IF (NP .EQ. MAXPA) GOTO 920 NP = NP + 1 NPT(I) = 1 MAXSIG(I) = ISIG(NP) + 9999 IF (I.EQ.1) ISAVE = MAXSIG(I) NUMA(I) = 1 NUMB(I) = 3 NUMC(I) = 3 IF (ABS(BPIK(NP)).GT.3. .AND. ABS(180.-BPIK(NP)).GT.3.) GOTO 842 II = 6 IF (KLAUE.EQ.3) II=3 AF(I) = APIK(NP) DELA = 60. BF(I) = 1. IF (ABS(BPIK(NP)).GT.3.) BF(I)=175. CF(I) = CPIK(NP) - DELC GOTO 843 842 II = 5 DELA = 12.5 AF(I) = APIK(NP) - 2. * DELA BF(I) = BPIK(NP) - DELB CF(I) = CPIK(NP) - DELC + 2. * DELA IF (ABS(BPIK(NP)).GT.12. .AND.ABS(180.-BPIK(NP)).GT.123.) GOTO 843 BF(I) = BF(I) - 1. NUMB(I) = 4 843 DO 844 J=1,II IF (MPAR .EQ. MAXPA) GOTO 920 CALL STOPAR (AF(I), BF(I), CF(I), * NUMA(I), NUMB(I), NUMC(I), MAXSIG(I)) NPTOT = NPTOT + NUMA(I) * NUMB(I) * NUMC(I) AF(I) = AF(I) + DELA CF(I) = CF(I) - DELA IF (AF(I).GT.AMAX+5.) THEN AF(I) = AF(I) - AMAX CF(I) = CF(I) + AMAX IF (CF(I) .GT. CMAX+5.) CF(I) = CF(I) - CMAX ENDIF IF (CF(I) .LT. -5.) CF(I) = CF(I) + CMAX 844 CONTINUE 849 CONTINUE 920 IF (SWPRI) WRITE (LIS2, 820) NP2, ISAVE, NPTOT WRITE (LIS2, 922) ISAVE 922 FORMAT (' Largest value in polar region :', I4) 950 DELC = DEC / 2. RETURN END SUBROUTINE SIGSEL (DELCX) 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)) LOGICAL XBIG EQUIVALENCE (XBIG, SWITCH(14)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) DATA MSIGFR /4/ DATA IRUN / 0 / DATA DELABC /0.0/ IRUN = IRUN + 1 IF (IRUN .GT. 1) GOTO 106 DELABC = 2. DELAB = 9. DELCA = 10. IF (XBIG) THEN DELAB = 7. DELCA = 7. ENDIF IF (MPARIN.LE.0) GOTO 110 DELABC = 0.4 * DELC DELAB = 1.5 * DELC DELCA = DELAB GOTO 110 106 MSIGFR = MSIGFR + 1 IF (XBIG) MSIGFR = MIN0 (MSIGFR, 5) DELABC = DELABC * 0.4 DELAB = DELAB * .75 DELCA = AMAX1(DELAB, DELCA * .65) 110 CALL RDMAPS (MSIGFR, NP) IF (DELABC.GT.1.9) THEN CALL NEBOR (0, NP, DELAB, DELCA, IANSW) ELSE CALL NEBORS (0, NP, DELAB, DELCA, CMAX, IANSW) ENDIF MP = 0 DO 150 IP = 1,NP IF (ISIG(IP).EQ.0) GOTO 150 MP = MP + 1 N = IP + 1 IF (N.GT.NP) GOTO 150 DO 140 L = N,NP IF (ISIG(L).EQ.0) GOTO 140 IF (DELABC.GT.1.9) THEN CALL NEBOR (IP, L, DELAB, DELCA, IANSW) ELSE CALL NEBORS (IP, L, DELAB, DELCA, CMAX, IANSW) ENDIF IF (IANSW.EQ.0) GOTO 140 ISIG(L) = 0 140 CONTINUE 150 CONTINUE IF (MP.EQ.NP) GOTO 170 WRITE (LIS2, 160) MP 160 FORMAT (' After rejecting neighbors', I4, ' points left') CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP) NP = MP GOTO 180 170 WRITE (LIS2, 172) 172 FORMAT (/' No neighbors rejected') 180 IF (NP .LE. 5) GOTO 201 NPMAX = 25 IF (XBIG) NPMAX = 53 NPLAST = NP IF (NP .GT. NPMAX) NP = NPMAX IRUNNP = 2*NP + 10*IRUN + 20 ISMAX = (MIN0 (IRUNNP, 70) * ISIG(1)) / 100 IF (XBIG) ISMAX = (MIN0 (IRUNNP, 55) * ISIG(1)) / 100 DO 184 IP = 2,NP IF (ISIG(IP) .LT. ISMAX) GOTO 190 184 CONTINUE GOTO 201 190 NP = IP - 1 201 WRITE (LIS2, FMT = '(I6,'' Highest points selected'')') NP WRITE (LIS2, FMT = '(''0Set No. A B C ISIG'')') DO 213 IP = 1,NP 213 WRITE (LIS2, 214) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP) 214 FORMAT (I4, 5X, 3F7.2, I7) DELA = DELABC DELB = DELABC DELC = DELABC DELCX = DELC IF (DELC.LT.0.35 .OR. IRUN.GE.3) THEN NPKS = NP RETURN ENDIF WRITE (LIS2,32) NP, DELABC 32 FORMAT ('0New ABC params,', * I4, ' sets, size 4*4*4, step-increments ', F5.2 ) NUMA = 4 NUMB = 4 NUMC = 4 DO 900 I=1,NP AF = APIK(I) - 1.5 * DELA BF = BPIK(I) - 1.5 * DELB CF = CPIK(I) - 1.5 * DELC 900 CALL STOPAR (AF, BF, CF, NUMA, NUMB, NUMC, ISIG(IP)) RETURN END SUBROUTINE RDMAPS (MSIGFR, NP) 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)) EQUIVALENCE (NRUN, KEYS(5)) LOGICAL SWPRI, NIJM EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB DIMENSION KARR(22) DATA MAXPKL / 501 / MFR = MAX0 (5, MSIGFR) MFR = MIN0 (8, MFR) WRITE (LIS2, 108) MFR 108 FORMAT (' Subr. RDMAPS: ISIG-minimum = maximum *',I2 , '/10') ISIGM = 0 ISIGT = 0 TSIG = 0. DO 150 II = 1, 2 CALL VALDIS (-1, TSIG, 2000., KARR, 22, KEND) N = 0 LSET = 0 DO 125 I = 1, NPKS IF (ISIG3(I,1) .LT. IMIN) THEN IF (NRUN .LE. 2) ISIG(I) = 0 GOTO 125 ENDIF IF (MMM3 .EQ. 3) THEN ISIG(I) = (10*ISIG3(I,1) + 3*ISIG3(I,2) + ISIG3(I,3)) / 14 ELSEIF (MMM3 .EQ. 2) THEN ISIG(I) = (2*ISIG3(I,1) + ISIG3(I,2)) / 3 ELSE ISIG(I) = ISIG3(I,1) ENDIF IF (ISIG(I).LT.ISIGT) GOTO 125 IF (NRUN.LE.2) GOTO 24 IF (NPIK(I).NE.LSET) GOTO 23 IF (ISIG(I) .LT. ISIG(N)) GOTO 125 IF (ISIG(I).GT.ISIG(I-1)) GOTO 22 APIK(N) = (APIK(N) + APIK(I)) / 2. BPIK(N) = (BPIK(N) + BPIK(I)) / 2. CPIK(N) = (CPIK(N) + CPIK(I)) / 2. GOTO 125 22 ISIG(N) = ISIG(I) APIK(N) = APIK(I) BPIK(N) = BPIK(I) CPIK(N) = CPIK(I) GOTO 125 23 LSET = NPIK(I) 24 N = N + 1 ISIG(N) = ISIG(I) APIK(N) = APIK(I) BPIK(N) = BPIK(I) CPIK(N) = CPIK(I) TSIG = ISIG(I) CALL VALDIS (0, TSIG, DUMM, KARR, 22, KEND) IF (ISIG(I).LE.ISIGM) GOTO 125 ISIGM = ISIG(I) ISIGT = MAX0 (ISIGT, (ISIGM*MFR)/10) 125 CONTINUE NPTS = N IF (NPTS .LT. MAXPKL) GOTO 200 WRITE (LIS2,35) NPTS 35 FORMAT (' Number of ABC points sent by MAPSIG =', I5) IF (II .GT. 1) GOTO 200 IF (NRUN.GE.3) THEN I = 7*ISIGM/10 IF (I .LT. ISIGT) I = 8*ISIGM/10 IF (I .GT. ISIGT) THEN ISIGT = I GOTO 30 ENDIF ENDIF CALL VALDIS (MAXPKL-50, TSIG, DUMM, KARR, 22, KEND) I = TSIG ISIGT = MAX0 (I, ISIGT+1) IF (ISIGT.LE.ISIGM) GOTO 30 ISIGT = ISIGM 30 WRITE (LIS2,36) ISIGT 36 FORMAT (' Reset min. value for ISIG to ', I5 ) 150 CONTINUE 200 NP = N CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP) ISIGTL = MIN0 (6* ISIG(1) / 10 + 1, ISIGT) IF (NIJM) WRITE(LIS1, FMT='('' NIJM result from RDMAPS:'', * '' ISIGmax, ISIGlim: '', 2I4)') ISIG(1), ISIGTL DO 2 I = 1, NP IF (ISIG(I).LT.ISIGTL) GOTO 3 2 CONTINUE GOTO 4 3 NP = I - 1 4 IF (NP .GT. MAXPKL) THEN ISIGT = ISIG(MAXPKL) NP = MAXPKL ENDIF NPKS = NP ISIGTL = ISIG(NP) IF (NIJM) WRITE(LIS1, FMT='('' NIJM result from RDMAPS:'', * '' ISIGmax, ISIGmin: '', 2I4)') ISIG(1), ISIGTL IF (NIJM) WRITE (LIS1,37) NP, ISIGT WRITE (LIS2,37) NP, ISIGT 37 FORMAT (I4, ' ABC points selected: new ISIGmin = ', I5) MPAR = 0 IF (.NOT. SWPRI) RETURN WRITE (LIS2,37) NP, ISIGT DO 40 I=1,NP 40 WRITE (LIS2,41) I,APIK(I),BPIK(I),CPIK(I), ISIG(I) 41 FORMAT (I5, 7H ABC = ,3F7.2, 8H ISIG =, I5) RETURN END SUBROUTINE NEBOR (IP, NB, DELAB, DELCA, ISW) 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)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB IF (IP .GT. 0) GOTO 20 NP = NB WRITE (LIS2, 5) DELAB, DELCA 5 FORMAT (' Step size for neighbors: delAB =', F6.2, * ' delCA =', F6.2) DO 10 I = 1,NP B1 = BPIK(I) * 0.017453 ASINB(I) = 0.5 * ABS(SIN(B1)) 10 CPLUSA(I) = CPIK(I) + APIK(I) GOTO 100 20 ISW=0 IF (ABS(BPIK(IP)-BPIK(NB)).GT.DELAB) GOTO 100 T = ABS(CPLUSA(IP)-CPLUSA(NB)) IF (T.GT.DELCA) GOTO 100 T = ASINB(IP) + ASINB(NB) IF (ABS (APIK(IP)-APIK(NB))*T.GT.DELAB) GOTO 100 ISW=1 100 RETURN END SUBROUTINE NEBORS (IP, NB, DELAB, DELCA, CMAX, ISW) 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 (KLAUE, KEYS(6)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB DATA AMAX, CAMAX, AMAX2, CAMAX2 / 4 * 0.0/ IF (IP .GT. 0) GOTO 20 NP = NB WRITE (LIS2, 5) DELAB, DELCA 5 FORMAT (' Step size for neighbors: delAB =', F6.2, * ' delCA =', F6.2) DO 10 I = 1,NP B1 = BPIK(I) * 0.017453 ASINB(I) = 0.5 * ABS(SIN(B1)) 10 CPLUSA(I) = CPIK(I) + APIK(I) AMAX = 360. IF (KLAUE.EQ.3) AMAX = 180. CAMAX = AMIN1(CMAX, AMAX) CAMAX2 = CAMAX / 2. AMAX2 = AMAX / 2. GOTO 100 20 ISW=0 KSYM = 0 IF (ABS(BPIK(IP)-BPIK(NB)).LE.DELAB) KSYM = 1 IF (ABS(BPIK(IP)+BPIK(NB)).LE.DELAB .OR. * ABS(BPIK(IP)+BPIK(NB) - 360.).LE.DELAB) KSYM = KSYM + 2 IF (KSYM.EQ.0) GOTO 100 T = AMOD (ABS(CPLUSA(IP)-CPLUSA(NB)), CAMAX) IF (T.GT.CAMAX2) T=ABS(CAMAX-T) IF (T.GT.DELCA) GOTO 100 IF (KSYM.EQ.2) GOTO 50 TT = ASINB(IP) + ASINB(NB) T = AMOD (ABS(APIK(IP)-APIK(NB)), AMAX) IF (T.GT.AMAX2) T=ABS(AMAX-T) IF (T * TT .LE.DELAB) GOTO 90 50 IF (KSYM.EQ.1) GOTO 100 TT = ABS(ASINB(IP) - ASINB(NB)) T = AMOD (ABS(APIK(IP)-APIK(NB) + 180.), AMAX) IF (T.GT.AMAX2) T=ABS(AMAX-T) IF (T * TT .GT.DELAB) GOTO 100 90 ISW=1 100 RETURN END SUBROUTINE STOPAR (AI, BI, CI, NA, NB, NC, ISIG) 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 SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) PARAMETER (MAXPA = 100) COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX, * MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA), * MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT, * AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA) MPAR = MPAR + 1 PAR1(1,MPAR) = AI PAR1(2,MPAR) = BI PAR1(3,MPAR) = CI PAR2(1,MPAR) = DELA PAR2(2,MPAR) = DELB PAR2(3,MPAR) = DELC NPAR(1,MPAR) = NA NPAR(2,MPAR) = NB NPAR(3,MPAR) = NC IF (SWPRI .AND. MPAR.EQ.1) * WRITE (LIS2, FMT='(16X, ''New ABC parameters''/ 16X, * ''Set Ast Ainc NA Bst Binc NB Cst Cinc NC ISIG'')') IF (SWPRI) WRITE (LIS2, 101) * MPAR, AI, DELA, NA, BI, DELB, NB, CI, DELC, NC, ISIG 101 FORMAT (I19, 3(F7.2, F6.2, I3), I5) RETURN END SUBROUTINE SORT4 (IX, A, B, C, N) DIMENSION IX(N), A(N), B(N), C(N) IF (N.LE.1) RETURN K = 2 10 K = K + K IF (K.LT.N) GOTO 10 K = MIN0 (N, (3*K)/4 - 1) 20 K = K/2 L = N-K DO 200 II=1,L I = II J = I+K IF (IX(I).GE.IX(J)) GOTO 200 IT = IX(J) AT = A(J) BT = B(J) CT = C(J) 80 IX(J)= IX(I) A(J) = A(I) B(J) = B(I) C(J) = C(I) J = I I = I-K IF (I) 140,140,120 120 IF (IX(I).LT.IT) GOTO 80 140 IX(J)= IT A(J) = AT B(J) = BT C(J) = CT 200 CONTINUE IF (K.NE.1) GOTO 20 RETURN END SUBROUTINE ORDEK 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)), (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 (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3), VMAXDE EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3)) EQUIVALENCE (NUMX, NUM(1)) INTEGER * 2 LPAT(198) DIMENSION NXYZM(3) EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3)) DIMENSION ITLE(20) EQUIVALENCE (FFTSC, ITLE(18)) DATA JXYZC, LXYZC / 0, 0 / DATA IZ, KXYZC, IXYZC / 0, 0, 0 / ILMAX = 49 DO 111 I = 1, NUMTAB 111 ITAB(I) = 0 MAXFUN = 30254 N254 = 0 MIFUN = 0 FUNSUM = 0. ILMA = ILMAX CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ) IF (KINQ.NE.0) CALL KERROR * ('Patterson file (FMAP) not found.', -1, 'PATIN') 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 , 'PATIN' ) 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 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-vector peak-height is approximately ' ,F10.2 /) K = 0 10 DO 12 I=1,3 L = (NXYZ(I)+1) / 2 IF (L.GT.ILMAX) K=1 LXYZ(I) = MIN0 (L, ILMAX) 12 IS(I) = 0 IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2) IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3) DO 14 I=1,3 NXYZM(I) = NXYZ(I) IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1 14 NUM(I) = LXYZ(I) - IS(I) + 1 NUMXY = NUM(1) * NUM(2) NUMXYZ = NUMXY * NUM(3) IF (NUMXYZ .LE. NUMTAB) GOTO 15 ILMAX = ILMAX - 1 GOTO 10 15 IF (ILMA .NE. ILMAX) THEN WRITE (CHOUT,16) ILMAX 16 FORMAT (' STORAGE PROBLEMS: ILMAX = ',I3, ' POINTS. ') CALL SHOUT2 ENDIF DO 217 I = 1,3 217 GTXYZ(I) = NXYZ(I) VMAXDE = 9999. DO 18 I=1,3 VV = (FLOAT(ILMAX) / FLOAT(NXYZ(I))) / RCELL(I) 18 IF (VV .LT. VMAXDE) VMAXDE = VV IF (K .EQ. 1) WRITE (LIS2, 20) VMAXDE 20 FORMAT (' DEK-storage limitations: max vector length:', F6.2) 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.2 .AND. IY.GT.ILMAX) K=3 IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1 IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0 IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0 IF (K.EQ.3) IXY=KXY 26 DO 48 I2=1,NZ IF (I2.GT.NZM) K=0 IF (K.EQ.0) GOTO 28 IZ = I2 - 1 IXYZ = NUMXY * IZ IXYZC = IXYZ + IXY - NUMC KXYZC = IXYZ + KXY - NUMC L = 1 IF (IS(3).EQ.0) GOTO 28 KZ = IZ - NZ JXYZ = NUMXY * KZ JXYZC = JXYZ + IXY - NUMC LXYZC = JXYZ + KXY - NUMC IF (IZ.GT.LXYZ(3)) L=3 IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2 IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3 IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1 IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0 IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0 IF (L.EQ.3) IXYZC=JXYZC IF (L.EQ.3) KXYZC=LXYZC 28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX) IF (K.EQ.0 .OR. L.EQ.0) GOTO 48 DO 40 I3=1,NXM FUN = LPAT(I3) FUN = 99. * ( FUN * SCAL + 25. ) IFUN = NINT(FUN) IF (IFUN) 32, 32, 30 30 IF (IFUN.GT.MIFUN) MIFUN=IFUN IF (IFUN .LE. MAXFUN) GOTO 36 IFUN = MAXFUN N254 = N254 + 1 GOTO 36 32 IFUN = 0 36 LPAT(I3) = IFUN FUNSUM = FUNSUM + FLOAT(IFUN) IX = I3 - 1 IADR = IXYZC + IX ITAB(IADR) = IFUN IADR = JXYZC + IX IF (L.EQ.2) ITAB(IADR) = IFUN IF (K.NE.2) GOTO 40 IADR = KXYZC + IX ITAB(IADR) = IFUN IADR = LXYZC + IX IF (L.EQ.2) ITAB(IADR) = IFUN 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) IFUN = FUNSUM WRITE (LIS2,52) MIFUN, N254, MAXFUN, IFUN 52 FORMAT (' Largest scaled Patterson value is: ', 15X, I5, / * 15X, I5,' values exceeded: ' , 13X, I5, / * 20X, ' averaged value is: ', 11X, I5, /) CALL PATMOD RETURN END SUBROUTINE PATMOD 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 LOGICAL SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (KLAUE, KEYS(6)) PARAMETER (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3), VMAXDE EQUIVALENCE (NUMX, NUM(1)), (NUMY,NUM(2)), (NUMZ,NUM(3)) IF (KLAUE.EQ.1) RETURN IF (SWPRI) WRITE (LIS2, FMT = '( * ''0Reduce Patterson values of mirror faces'' )') GOTO (2,2,3,4), KLAUE 2 CONTINUE DO 22 K = 1,2 DO 22 L = 1,3 FF = .85 IF (K.EQ.1 .OR. L.EQ.2) FF = .75 IF (K.EQ.1 .AND.L.EQ.2) FF = .5 IX = K - 1 IZ = L - 2 IY = IS(2) - 1 DO 22 I = 1, NUMY IY = IY + 1 IADR = NUMXY * IZ + NUMX * IY + IX - NUMC IJX = ITAB(IADR) FFF = FLOAT( IJX ) IFUN = NINT (FFF * FF) ITAB(IADR) = IFUN 22 CONTINUE GOTO 3 4 CONTINUE DO 440 K = 1,2 DO 440 L = 1,3 FF = .85 IF (K.EQ.1 .OR. L.EQ.2) FF = .75 IF (K.EQ.1 .AND.L.EQ.2) FF = .5 IX = K - 1 IY = L - 2 IZ = IS(3) - 1 DO 440 I = 1, NUMZ IZ = IZ + 1 IADR = NUMXY * IZ + NUMX * IY + IX - NUMC IJX = ITAB(IADR) FFF = FLOAT( IJX ) IFUN = NINT (FFF * FF) ITAB(IADR) = IFUN 440 CONTINUE 3 CONTINUE GOTO (20,20,30,40) , KLAUE 30 DO 31 K=1,2 IX = K - 1 FF = .5 IF (IX.EQ.1) FF=.75 IY = IS(2) - 1 DO 31 I = 1, NUMY IY = IY + 1 IZ = IS(3) - 1 DO 31 J = 1, NUMZ IZ = IZ + 1 IADR = NUMXY * IZ + NUMX * IY + IX - NUMC IJX = ITAB(IADR) FFF = FLOAT( IJX ) IFUN = NINT (FFF * FF) ITAB(IADR) = IFUN 31 CONTINUE 20 DO 21 K=1,2 IY = K - 1 FF = .5 IF (IY.EQ.1) FF=.75 IX = IS(1) - 1 DO 21 I = 1, NUMX IX = IX+ 1 IZ = IS(3) - 1 DO 21 J = 1, NUMZ IZ = IZ + 1 IADR = NUMXY * IZ + NUMX * IY + IX - NUMC IJX = ITAB(IADR) FFF = FLOAT( IJX ) IFUN = NINT (FFF * FF) ITAB(IADR) = IFUN 21 CONTINUE IF (KLAUE.EQ.2) RETURN 40 DO 41 K=1,2 IZ = K - 1 FF = .5 IF (IZ.EQ.1) FF=.75 IX = IS(1) - 1 DO 41 I = 1, NUMX IX = IX+ 1 IY = IS(2) - 1 DO 41 J = 1, NUMY IY = IY + 1 IADR = NUMXY * IZ + NUMX * IY + IX - NUMC IJX = ITAB(IADR) FFF = FLOAT( IJX ) IFUN = NINT (FFF * FF) ITAB(IADR) = IFUN 41 CONTINUE RETURN END SUBROUTINE RDOUT (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 (MAXPK = 1234, NUMTAB = 200000) COMMON / / NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK), * ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS, * ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB) INTEGER * 2 ITAB COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC, * GTXYZ(3), LXYZ(3), VMAXDE 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)) 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 1000 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 1000 DO 712 IX=1,3 T = RARG(IX) * GTXYZ(IX) I = IFIX(T) IF (T.GE.0.) GOTO 711 I = I - 1 IF (I.LT.-LXYZ(IX)) I=I+1 GOTO 712 711 IF (I.EQ.LXYZ(IX)) I=I-1 712 INEAR(IX) = I K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC K222 = K111 + 1 + NX + NXY IJX = ITAB(K111) FUNNER = FLOAT( IJX ) / 99. IJX = ITAB(K111 + 1) FUNX = FLOAT( IJX ) / 99. IJX = ITAB(K111 + NX) FUNY = FLOAT( IJX ) / 99. IJX = ITAB(K111 + NXY) FUNZ = FLOAT( IJX ) / 99. IJX = ITAB(K222) FUNFAR = FLOAT( IJX ) / 99. IJX = ITAB(K222 - 1) FUNYZ = FLOAT( IJX ) / 99. IJX = ITAB(K222 - NX) FUNXZ = FLOAT( IJX ) / 99. IJX = ITAB(K222 - NXY) FUNXY = FLOAT( IJX ) / 99. FUNF= AMAX1(FUNNER, FUNX, FUNY, FUNZ, FUNFAR, FUNYZ, FUNXZ, FUNXY) RETURN END SUBROUTINE SYMM (X, Y, Z) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) EQUIVALENCE (KLAUE, KEYS(6)) GOTO (5, 15, 25, 35), KLAUE 5 IF (X.GE.0.0) RETURN X = -X Y = -Y Z = -Z RETURN 15 Y = ABS(Y) IF (X.GE.0.0) RETURN X = -X Z = -Z RETURN 25 X = ABS(X) Y = ABS(Y) Z = ABS(Z) RETURN 35 Z = ABS(Z) IF (X.GE.0.0) RETURN X = -X Y = -Y RETURN END