PROGRAM LEPAGE * ********************************************************************** * * * PROGRAM TO DETERMINE THE METRICAL SYMMETRY OF A GIVEN LATTICE * * ============================================================= * * * * PC/BASIC, VERSION 22/04/85, UTRECHT, A.L. SPEK. * * UPDATE 26/09/85, 02/04/88, 09/05/88, * * * * CONVERTED TO FORTRAN V, * * * * VERSION 21/08/85, GRONINGEN, A. MEETSMA. * * UPDATE 31/10/85, 03/12/85, 04/05/87, 19/05/87. * * * * INTERACTIVE VERSION (FREE FORMAT INPUT) 14/12/87. * * UPDATE 25/02/88. * * WITH SUB AND SUPER CELLS: 28/04/88, 11/05/88. * * * * UNIX-VERSION - UTRECHT - 1991 - A.L. SPEK * * ********************************************************************** * * * G(3,3) - METRICAL MATRIX OF DIRECT CELL * * OR(3,3) - [T] = [OR] [U]; DIRECT SPACE ORTHOGONALILSATION * * ROT(3,3) - [TAU] = [ROT][H]; RECIPROCAL SPACE ORTHOGONALISATION * * (IN PROGRAM U AND H ARE IN(K,1-3) AND IN(J,1-3), RESP * * TM(3,3,127)- TABLE WITH TRANSFORMATION MATRICES IN CELL REDUCTION * * - SUPER CELL AND SUB CELL LATTICES * * TMX(3,3,8) - TABLE WITH TRANSFORMATION MATRICES SAVED * * - CENTERED TO PRIMITIVE CELL TRANSFORMATION * * TP(3,3) - ACCUMALATED TRANSFORMATION * * TPS(3,3) - SAVED INPUT TO REDUCED CELL * * ********************************************************************** * * * TEST DATA IS GIVEN ON TAPE1. * * * * INPUT CAN BE GIVEN ON TAPE2 OR/AND INTERACTIVE (TAPE5): * * A, B, C, ALFA, BETA, GAMMA AND NR. * * - NR IS A NUMBER CORRESPONDING WITH CELL TYPE: 1, 2, 3, 4, 5, 6, * * 7, 8, FOR P, I, R, F, A, B, C AND X, RESPECTIVELY * * IF TYPE X(=8), THEN THE NINE ELEMENTS OF TP(I,J) SHOULD * * FOLLOW ON A --TRMX-- INSTRUCTION. * * IF B .EQ. A OR C .EQ. B THAN B AND/OR C MAY BE INPUT AS 0 * * IF ALFA, BETA, OR GAMMA .EQ. 90 DEGREE THEN INPUT MAY BE 0 * * * * * * - A POSSIBLE HARDCOPY PRINT IS PROVIDED BY THE CCL PROCEDURE * * ********************************************************************** * * * DEFAULT VALUES: * * -------------- * * - CRITICAL ANGLE: 2.5 DEGREE (CRIT - OPTION) * * - CLASSIFICATION METRICAL: .LT. 0.01 DEGREE (METR - OPTION) * * * * ********************************************************************** * --- F I L E S --- * * ===================== * * LI TAPE1 - TEST CELLS >>> LEPAGE_TST (INPUT) * * LD TAPE2 - INSTRUCTION INPUT FILE >>> LEPAGE_INP (INPUT) * * LG TAPE5 - (TERMINAL) INPUT FILE * * LH TAPE6 - (TERMINAL) OUTPUT FILE (OUTPUT) * * LP TAPE7 - OUTPUT LISTING FILE >>> LEPAGE_LIS (OUTPUT) * * * * ---------------------------------------------------------------------* * --- G L O S S A R Y --- * * ========================= * * * * P A R A M E T E R S * * -------------------------------------------------------------------- * * * * 0/1 = NO/YES * * * * ISW(1) = 0/1 - ON/OFF PRINT (HARD COPY LISTING) * * ISW(2) = 0/1 - /SUB LATTICES * * ISW(3) = 0/1 - /SUPER LATTICES * * ISW(4) = 0/1 - /LATT INPUT * * ISW(5) = 0/1 - /MORE OUTPUT ON THE SCREEN * * ISW(6) = 0/1 - /CALCULATION DONE (CELL LISTING) * * ISW(7) = 0/1 - /CHANGE IN CRIT AND/OR MAXDM * * ISW(8) = 0/1 - /CELL INPUT * * ISW(9) = 0/1 - /TEST-CELL * * ISW(10)= 0/1 - /NOSCREEN OUTPUT (USEFULL IN CASE OF * * SUB AND SUPER CELL..... * * * * ....FIRST VALUE IS DEFAULT (NO/YES) * * * * -------------------------------------------------------------------- * * * * PAR(1) = CONVERSION DEGREE TO RADIAN * * PAR(2) = CRITICAL ANGLE * * PAR(3) = CLASSIFICATION METRICAL * * PAR(4) = * * PAR(5) = * * * * * * LATT(1) = ORIGINALE LATTICE * * LATT(2) = REDUCED LATTICE * * LATT(3) = CONVENTIONAL LATTICE * * LATT(4) = TEST LATTICE * * LATT(5) = * * * * ==================================================================== * * * * --- M A I N P R O G R A M --- * * * REAL AA(3,3), BB(3,3) LOGICAL TRS CHARACTER LATT*1, LAT*1, CHAR*1, VERSION*10, LOOPT*5, CDET*5 COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET COMMON /TAPES/ LI, LD, LO, LF, LG, LH, LP COMMON /FR/ ICL(80), IFL(31,7), FN(31) COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET * *** TX(3,3): STORE THE [X]-MATRIX...... EQUIVALENCE (TP(1,1),AA(1,1)) DATA LI, LD, LO, LF, LG, LH, LP /1,2,3,4,5,6,7/ VERSION = ' 20/10/89.' * *** INITIALIZE DATA..... PAR(1) = ATAN(1.0)/45.0 PAR(2) = 2.5 PAR(3) = 0.01 * 0.01 DEGREE (DEFAULT) IS USED TO CLASSIFYING PSEUDO/METRICALLY! ISKP = 15 NRS = ISKP + 1 NRI = ISKP + 1 NRSL = 1 IDET = 1 ITST = 42 LATT(1) = 'P' LATT(2) = 'P' LOOPT = 'SUPER' CDET = ' DET' IAA = 0 ITESTR = 0 NR = 1 NBCELL = 0 TRS = .TRUE. OPEN(UNIT= LI,FILE='lepage.tst',STATUS='OLD', 1 FORM='FORMATTED',ERR=5) 5 CONTINUE OPEN (UNIT=LP,FILE='lepage.lis',STATUS='UNKNOWN') OPEN (UNIT=LD,FILE='lepage.inp',STATUS='UNKNOWN', ERR=1) GOTO 2 1 WRITE (LH, 5000) 5000 FORMAT (' ::FILE >>> LEPAGE.INP <<< NOT AVAILABLE, ', . 'INTERACTIVE INPUT ASSUMED.....', /) 2 REWIND (LI) REWIND (LD) REWIND (LP) DO 10 I=1,10 ISW(I) = 0 10 CONTINUE DO 20 I=1,3 OCELL(I) = 10.0 OCELL(I+3) = 90.0 20 CONTINUE OCELL(7) = 1000.0 DO 30 I=1,75 ITLE(I) = ' ' 30 CONTINUE CALL LEPAG09 DO 60 I=1,3 DO 50 J=1,3 DO 40 K=1,8 TMX(I,J,K) = TM(I,J,K) 40 CONTINUE 50 CONTINUE 60 CONTINUE ISW(7) = 1 * *** OUTPUT HEADER WRITE (LH,99977) VERSION * *** OUTPUT HEADER TO LEPAGE_LIS...... CALL LEPAG02(LP, VERSION) * READ FIRST SPECIFIC INPUT FROM LEPAGE_INP LX = LD 70 IF (LX.EQ.LG) WRITE (LH,99991) READ (LX,99999,ERR=80,END=80) ICL WRITE (LH,99998) ICL CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80) IF (KL.EQ.0 .AND. KN.EQ.0) GO TO 70 IF (IFL(KL,1).EQ.1H=) GO TO 70 N1 = IFL(1,1) N2 = IFL(1,2) N3 = IFL(1,3) N4 = IFL(1,4) IF (N1.EQ.1HM .AND. N2.EQ.1HA .AND. N3.EQ.1HN .AND. N4.EQ.1HU) GO 1 TO 90 IF (N1.EQ.1HH .AND. N2.EQ.1HE .AND. N3.EQ.1HL .AND. N4.EQ.1HP) GO 1 TO 100 IF (N1.EQ.1HT .AND. N2.EQ.1HI .AND. N3.EQ.1HT .AND. N4.EQ.1HL) GO 1 TO 110 IF (N1.EQ.1HC .AND. N2.EQ.1HR .AND. N3.EQ.1HI .AND. N4.EQ.1HT) GO 1 TO 130 IF (N1.EQ.1HM .AND. N2.EQ.1HE .AND. N3.EQ.1HT .AND. N4.EQ.1HR) GO 1 TO 140 IF (N1.EQ.1HS .AND. N2.EQ.1HU .AND. N3.EQ.1HB) GO TO 160 IF (N1.EQ.1HS .AND. N2.EQ.1HU .AND. N3.EQ.1HP .AND. N4.EQ.1HE) GO 1 TO 150 IF (N1.EQ.1HC .AND. N2.EQ.1HE .AND. N3.EQ.1HL .AND. N4.EQ.1HL) GO 1 TO 170 IF (N1.EQ.1HD .AND. N2.EQ.1HA .AND. N3.EQ.1HT .AND. N4.EQ.1HA) GO 1 TO 170 IF (N1.EQ.1HL .AND. N2.EQ.1HA .AND. N3.EQ.1HT .AND. N4.EQ.1HT) GO 1 TO 190 IF (N1.EQ.1HT .AND. N2.EQ.1HR .AND. N3.EQ.1HA .AND. N4.EQ.1HN) GO 1 TO 240 IF (N1.EQ.1HN .AND. N2.EQ.1HO .AND. N3.EQ.1HS .AND. N4.EQ.1HC) GO 1 TO 280 IF (N1.EQ.1HT .AND. N2.EQ.1HR .AND. N3.EQ.1HM .AND. N4.EQ.1HX) GO 1 TO 230 IF (N1.EQ.1HP .AND. N2.EQ.1HR .AND. N3.EQ.1HI .AND. N4.EQ.1HN) GO 1 TO 290 IF (N1.EQ.1HM .AND. N2.EQ.1HO .AND. N3.EQ.1HR .AND. N4.EQ.1HE) GO 1 TO 300 IF (N1.EQ.1HT .AND. N2.EQ.1HE .AND. N3.EQ.1HS .AND. N4.EQ.1HT) GO 1 TO 320 IF (N1.EQ.1HC .AND. N2.EQ.1HA .AND. N3.EQ.1HL .AND. N4.EQ.1HC) GO 1 TO 370 IF (N1.EQ.1HL .AND. N2.EQ.1HI .AND. N3.EQ.1HS) GO TO 450 IF (N1.EQ.1HE .AND. N2.EQ.1HN .AND. N3.EQ.1HD) GOTO 470 IF (N1.EQ.1HQ .AND. N2.EQ.1HU .AND. N3.EQ.1HI .AND. N4.EQ.1HT) GO 1 TO 470 IF (N1.EQ.1HS .AND. N2.EQ.1HT .AND. N3.EQ.1HO) STOP 1 ' -- FORCED STOP OF LEPAGE--' IF (LX.EQ.LG) WRITE (LH,99992) GO TO 70 * *** >>EOF<< .......................................................... 80 CONTINUE IF (LX.EQ.LG) REWIND (LG) IF (LX.EQ.LD) LX = LG GO TO 70 * *** MANUAL............................................................ 90 CONTINUE CALL LEPAG02(LH, VERSION) GO TO 70 * *** HELP.............................................................. 100 CONTINUE CALL LEPAG02(LH, VERSION) GO TO 70 * *** TITL.............................................................. 110 CONTINUE DO 120 I=6,81 ITLE(I-5) = ICL(I) 120 CONTINUE GO TO 70 * *** CRIT.............................................................. 130 CONTINUE PAR(2) = FN(1) IF (PAR(2).LE.0.0 .OR. PAR(2).GT.5.0) PAR(2) = 1.0 ISW(7) = 1 GO TO 70 * *** METR.............................................................. 140 CONTINUE PAR(3) = FN(1) IF (PAR(3).LE.0.0 .OR. PAR(3).GT.1.0) PAR(3) = 0.1 ISW(7) = 1 GO TO 70 * *** SUPER LATTICE..................................................... 150 CONTINUE LOOPT = 'SUPER' CDET = ' DET' ISKP = 15 NRI = ISKP + 1 IDET = NINT(FN(1)) IF (IDET.EQ.4) THEN NRS = 71 NRSL = 56 ELSE IF (IDET.EQ.3) THEN NRS = 36 NRSL = 21 ELSE IF (IDET.EQ.2) THEN NRS = 23 NRSL = 8 ELSE IF (IDET.EQ.1) THEN NRS = 16 NRSL = 1 ELSE IDET = 1 NRS = 16 NRSL = 1 END IF ISW(2) = 0 ISW(3) = 1 GO TO 70 * *** SUB LATTICE....................................................... 160 CONTINUE LOOPT = 'SUB ' CDET = '1/DET' ISKP = 71 NRI = ISKP + 1 IDET = NINT(FN(1)) IF (IDET.EQ.4) THEN NRS = 127 NRSL = 56 ELSE IF (IDET.EQ.3) THEN NRS = 93 NRSL = 21 ELSE IF (IDET.EQ.2) THEN NRS = 79 NRSL = 8 ELSE IF (IDET.EQ.1) THEN NRS = 72 NRSL = 1 ELSE IDET = 1 NRS = 72 NRSL = 1 END IF ISW(2) = 1 ISW(3) = 0 GO TO 70 * *** CELL/DATA......................................................... 170 CONTINUE NR = 1 WRITE (LH,99997) IF (KN.LT.6) GO TO 460 DO 180 I=1,6 OCELL(I) = FN(I) 180 CONTINUE IF (OCELL(2).EQ.0.0) OCELL(2) = OCELL(1) IF (OCELL(3).EQ.0.0) OCELL(3) = OCELL(2) IF (OCELL(4).EQ.0.0) OCELL(4) = 90.0 IF (OCELL(5).EQ.0.0) OCELL(5) = 90.0 IF (OCELL(6).EQ.0.0) OCELL(6) = 90.0 IF (OCELL(1).LT.0.01 .OR. OCELL(1).GT.150.0 .OR. OCELL(2).LT.0.01 1 .OR. OCELL(2).GT.150.0 .OR. OCELL(3).LT.0.01 .OR. 2 OCELL(3).GT.150.0 .OR. OCELL(4).GT.180.0 .OR. OCELL(5).GT.180.0 3 .OR. OCELL(6).GT.180.0) THEN WRITE (LH,99996) ELSE OCELL(7) = VOLUME(OCELL) ISW(8) = 1 IF (KN.GT.6) NR = FN(7) IF (KL.GT.1) GO TO 200 IF (NR.GT.0) GO TO 220 END IF GO TO 70 * *** LATT.............................................................. 190 CONTINUE IF (KN.NE.0) THEN NR = NINT(FN(1)) GO TO 220 END IF 200 WRITE (LATT(1) ,99990) IFL(2,1) * LATTICES TYPE DO 210 IP=1,8 NR = IP IF (LATT(1).EQ.LAT(IP)) GO TO 220 IF ((IP.EQ.8) .AND. (LATT(1).NE.LAT(IP))) THEN WRITE (LH,99995) GO TO 70 END IF 210 CONTINUE 220 ISW(4) = 1 LATT(1) = LAT(NR) IF (NR.EQ.8) WRITE (LH,99987) GO TO 70 * *** TRMX.............................................................. 230 CONTINUE NR = 8 * *** TRAN.............................................................. 240 CONTINUE IF (KN.NE.9) GO TO 460 K = 0 DO 260 I=1,3 DO 250 J=1,3 K = K + 1 TX(I,J) = FN(K) TP(I,J) = FN(K) 250 CONTINUE 260 CONTINUE CALL SMINV(AA, BB, DET) DO 270 LQ=6,7 WRITE (LQ,99983) ((TP(I,J),J=1,3),(BB(I,J),J=1,3), I=1,2) 1 , DET, (TP(3,J),J=1,3), (BB(3,J),J=1,3) IF (DET.LE.0.0) THEN IF (DET.LT.0.0) WRITE (LH,99986) IF (DET.EQ.0.0) WRITE (LH,99985) WRITE (LH,99984) GO TO 70 END IF 270 CONTINUE IF (NR.EQ.8) GO TO 70 CALL METRIC(OCELL, G) CALL TRMETR(G, TP) CALL NEWCON(G, OCELL) WRITE (LH,99980) WRITE (LH,99979) LAT(1), (OCELL(I),I=1,7) GO TO 70 * *** NO SCREEN -- TOGGLE........................................... 280 CONTINUE IPR = 10 GO TO 310 * *** HARD COPY -- TOGGLE........................................... 290 CONTINUE IPR = 1 GO TO 310 * *** MORE OUTPUT -- TOGGLE........................................... 300 CONTINUE IPR = 5 310 IF (KL.EQ.1) THEN ISW(IPR) = IABS(ISW(IPR)-1) ELSE IF (IFL(2,2).EQ.1HN) ISW(IPR) = 1 IF (IFL(2,2).EQ.1HF) ISW(IPR) = 0 END IF GO TO 70 * *** TEST.............................................................. 320 CONTINUE IF (ITESTR.GT.0) THEN IAA = ITESTR GO TO 330 END IF IAA = NINT(FN(1)) IF (IAA.LT.-2 .OR. IAA.GT.ITST) THEN WRITE (LH,99988) GO TO 70 END IF * *** SEARCH, LOAD AND RUN TEST EXAMPLE IF (IAA.LE.0) THEN IAA = ITST ITESTR = ITST IF (IAA.EQ.-1) THEN IDET = 4 NRS = 71 NRSL = 56 ISKP = 15 NRI = ISKP + 1 LOOPT = 'SUPER' CDET = ' DET' ELSE IF (IAA.EQ.-2) THEN IDET = 4 NRS = 127 NRSL = 56 ISKP = 71 NRI = ISKP + 1 LOOPT = 'SUB ' CDET = '1/DET' ELSE IDET = 1 NRS = 16 NRSL = 1 LOOPT = ' ' CDET = ' ' END IF END IF 330 REWIND (LI) IA = (IAA-1)*3 DO 340 I=1,IA READ (LI,99999,ERR=460,END=460) ICL 340 CONTINUE READ (LI,99999,ERR=460,END=460) ITLE READ (LI,99999,ERR=460,END=460) ICL CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80) DO 350 I=1,6 OCELL(I) = FN(I) 350 CONTINUE NR = NINT(FN(7)) OCELL(7) = VOLUME(OCELL) READ (LI,99999,ERR=460,END=460) ICL CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80) DO 360 I=1,6 TCELL(I) = FN(I) 360 CONTINUE TCELL(7) = VOLUME(TCELL) LATT(4) = LAT(NINT(FN(7))) ISW(4) = 1 ISW(8) = 1 ISW(9) = 1 IF (ITESTR.EQ.0) GO TO 70 * *** CALC.............................................................. 370 CONTINUE IF (ISW(7).EQ.1) WRITE (LP,99976) PAR(2), PAR(3) IF (NBCELL.NE.0) GO TO 380 380 IF (ISW(8).EQ.0) WRITE (LH,99982) ISW(6) = 0 NBCELL = NBCELL + 1 DO 390 I=1,7 CELL(I) = OCELL(I) 390 CONTINUE LATT(1) = LAT(NR) DO 400 LQ=6,7 WRITE (LQ,99981) NBCELL, (ITLE(I),I=1,75) 400 CONTINUE 410 CALL LEPAG01(TRS, NR) NRI = NRI + 1 IF (NRI.LE.NRS) THEN DO 420 I=1,6 CELL(I) = OCELL(I) 420 CONTINUE IF (ISW(9).EQ.0) THEN WRITE (LH,99989) CHAR = 'Y' READ (LG,99999,ERR=430,END=430) CHAR 430 IF (CHAR(1:1).EQ.'Y' .OR. char(1:).eq.'y') GOTO 410 ELSE GO TO 410 END IF END IF NRI = ISKP + 1 IF (ITESTR.GT.0) THEN ITESTR = ITESTR - 1 GO TO 320 END IF ISW(6) = 1 ISKP = 15 NRS = ISKP + 1 NRI = ISKP + 1 NRSL = 1 IDET = 1 LATT(1) = 'P' LOOPT = 'SUPER' CDET = ' DET' IAA = 0 DO 440 I=1,75 ITLE(I) = ' ' 440 CONTINUE ISW(7) = 0 WRITE (LH,99993) (NBCELL+1) GO TO 70 * *** LIST.............................................................. 450 CONTINUE WRITE (LH,99975) ISW(2), ISW(3), IDET, ISW(10), ISW(1), ISW(5), 1 PAR(2), PAR(3) WRITE (LH,99980) WRITE (LH,99979) LAT(1), (OCELL(I),I=1,7) IF (ISW(6).NE.0) WRITE (LH,99978) LAT(3), (CELL(L),L=1,7) GO TO 70 * *** >>>MISTAKE<<< .................................................... 460 CONTINUE WRITE (LH,99992) GO TO 70 * *** QUIT.............................................................. 470 CONTINUE 490 CONTINUE 500 STOP ' --- LEPAGE DONE ---' 99999 FORMAT (80A1) 99998 FORMAT (/' CONTROL CARD...', 80A1/) 99997 FORMAT (' INPUT OF LATTICE PARAMETERS TO BE CHECKED FOR METRICAL', 1 ' SYMMETRY') 99996 FORMAT (' INPUT CELLPARAMETERS OUTSIDE THE LIMITS:'/' ... 0 -- ', 1 '150 ANGSTR. AND 0 -- 180 DEGREES ...') 99995 FORMAT (' --- SOMETHING WRONG WITH LATTICE TYPE ---') 99994 FORMAT (' CELL ', 3(F9.5, 1X), 3(F9.4, 1X), I3) 99993 FORMAT (//' .....GIVE INPUT ITEMS FOR THE NEXT CELL....', 1 ' (NUMBER: ', I2, ')'//) 99992 FORMAT (' >> UNKOWM KEYWORD (AND/OR WRONG INPUT DATA); IGNORED') 99991 FORMAT (' >>', $) 99990 FORMAT (1A1) 99989 FORMAT (' .....CONTINUE (Y/N)? Y') 99988 FORMAT (' "NO TEST DATA FOR THIS NUMBER!"') 99987 FORMAT (//' => => => YOU SHOULD GIVE A SPECIAL MATRIX', 1 ' [X] TO BE APPLIED TO THE', /, 1 20X, ' INPUT CELL BEFORE CELL REDUCTION PROCES!!!', //, 2 ' => => => INSTR.: '//) 99986 FORMAT (//' THE TRANSFORMATION CAUSED A CHANGE OF HANDEDNESS', 1 ' OF THE COORDINATE SYSTEM!!') 99985 FORMAT (//' THE NEW AXIS ARE COPLANAR!!') 99984 FORMAT (' ------ TRY ANOTHER TRANSFORMATION MATRIX ------') 99983 FORMAT (//' THE NEW TRANSFORMATION MATRIX , THE INVERSE ', 1 'AND THE DETERMINANT ARE RESP.:'//3X, '(A'') (', 3F5.2, 2 ') (A)', 4X, '(A) (', 3F5.2, ') (A'')'/3X, '(B'') = (', 3F5.2, 3 ') (B),', 3X, '(B) = (', 3F5.2, ') (B''),', 3X, 'DET. =', 4 F6.2/3X, '(C'') (', 3F5.2, ') (C)', 4X, '(C) (', 3F5.2, 5 ') (C'')') 99982 FORMAT (/' ERROR..... NOT YET GIVEN THE CELL CONSTANTS') 99981 FORMAT ('1'/' CELL CONTROL NO.: ', I2/1X, 24(1H=)//' FROM: ', 1 75(A1)/) 99980 FORMAT (//14X, 'LATT', 4X, 'A', 7X, 'B', 7X, 'C', 7X, 'ALF', 5X, 1 'BET', 5X, 'GAM', 6X, 'VOL'/1X, 75(1H-)) 99979 FORMAT (' INPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2) 99978 FORMAT (' OUTPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2) 99977 FORMAT (//' * ', 67(1H=), ' *'/' *', 69(1H ), '*'/' * ', 1 ' M E T R I C A L S Y M M E T R Y P R O G R A M', 2 ' *'/' * = = = = = = = = = = = = = = =', 3 ' = = = = = = = = *'/' *', 69(1H ), '*'/' * ', 67(1H*), 4 ' *'/' * ***** NOTICE ***** EXPERIMENTAL VERSION, MAY CONTAIN', 5 ' ERRORS ****** *'/' * ', 67(1H*), ' *'/' * ', 67(1H ), ' *'/ 6 ' *', 68(1H ), ' *'/' *', 15X, '***** L E P A G E *****', 30X, 7 ' *'/' *', 21X, '= = = = = =', 36X, ' *'///' LEPAGE - ', 8 'EXP. VERSION:', A10, ' - TYPE FOR HELP'/) 99976 FORMAT (//8X, ' THE CRITICAL VALUES USED ARE:'/6X, 39(1H=)/8X, 1 'BETWEEN THE AXES => ', F6.3, ' DEGREE'/8X, 'PSEUDO/METRICAL', 2 ' => ', F6.3, ' DEGREE'/6X, 39(1H=)/) 99975 FORMAT (//' ....FLAGS: - SUB - SUPER - IDET - NOSCREEN - PRINT', 1 ' - MORE - CRIT - METR - '/16X, I2, 5X, I2, 6X, I2, 6X, I2, 2 8X, I2, 6X, I2, 5X, F4.1, 4X, F4.3) 99972 FORMAT ( ' ......FILE OPEN ERROR ', /) END SUBROUTINE LEPAG01(TRS, NR) INTEGER DOT REAL MAXD, V(3), ORT(3,3), TAU(3) LOGICAL TRS, CHANGE CHARACTER LATT*1, LAT*1, LOOPT*5, CDET*5 COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET * *** TRANSFORMATION MATRICES OF "DEPARTURE" USED IN CELL REDUCTION DO 30 I=1,3 DO 20 J=1,3 DO 10 K=1,8 TM(I,J,K) = TMX(I,J,K) 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (NR.EQ.8) GO TO 70 DO 60 J=1,3 DO 50 K=1,3 TP(J,K) = 0.0 DO 40 I=1,3 TP(J,K) = TP(J,K) + TM(J,I,NRI)*TM(I,K,NR+8) 40 CONTINUE 50 CONTINUE 60 CONTINUE * *** CALCULATE THE METRIC TENSOR. 70 CALL METRIC(CELL, G) * SAVE METRIC IN GI DO 90 I=1,3 DO 80 J=1,3 GI(I,J) = G(I,J) 80 CONTINUE 90 CONTINUE CELL(7) = VOLUME(CELL) DO 100 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 100 WRITE (LQ,99999) WRITE (LQ,99998) LAT(NR), (CELL(L),L=1,7) 100 CONTINUE * TRANSFORM METRICAL MATRIX FOR INPUT CELL CALL TRMETR(G, TP) * GET NEW CELL CONSTANTS FROM M (METRICAL MATRIX) CALL NEWCON(G, CELL) CELL(7) = VOLUME(CELL) DO 110 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 110 WRITE (LQ,99997) LATT(2), (CELL(L),L=1,7) 110 CONTINUE * FIND REDUCED CELL CALL REDUCED(TRS, G, TM) CALL NEWCON(G, CELL) CELL(7) = VOLUME(CELL) DO 120 I=1,7 RCELL(I) = CELL(I) 120 CONTINUE DO 130 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 130 WRITE (LQ,99996) LATT(2), (CELL(L),L=1,7), (TP(1,J),J=1,3), 1 (TP(2,J),J=1,3), G(1,1), G(2,2), G(3,3), (TP(3,J),J=1,3), 2 G(2,3), G(1,3), G(1,2) 130 CONTINUE * SAVE INPUT TO REDUCED CELL TRANSFORMATION MATRIX DO 150 I=1,3 DO 140 J=1,3 TPS(I,J) = TP(I,J) 140 CONTINUE 150 CONTINUE * *** CALCULATE ORTHOGONALISATION MATRICES (=> [OR]) CALL ORTHOG(CELL, OR) * *** CALCULATE THE TRANSPOSE OF OR (=> [ORT]) CALL STRP(OR, ORT) * *** CALCULATE THE INVERSE OF ORT (=> [ROT]) CALL SMINV(ORT, ROT, DET) * *** TRANSFORM U, V, W TO ORTHOGONAL COORDINATES. DO 180 K=1,37 DO 160 I=1,3 V(I) = FLOAT(IN(K,I)) 160 CONTINUE CALL SMATVEC(OR, V, T) DKW = 0.0 DO 170 J=1,3 TT(K,J) = T(J) TT(K,J+3) = T(J)*T(J) DKW = DKW + TT(K,J+3) 170 CONTINUE TT(K,7) = T(1)*T(2) TT(K,8) = T(1)*T(3) TT(K,9) = T(2)*T(3) TT(K,10) = SQRT(ABS(DKW)) TT(K,11) = K 180 CONTINUE * ORDER VECTOR LIST: SORT ON LENGTH: * BUBLE SORT WITH SWAPPING OF THE SEQUENCE NUMBERS * ----- SEQUENCE NUMBER IN TT(K,11)!! ----- 190 CHANGE = .FALSE. DO 200 K=1,36 IF (TT(NINT(TT(K,11)),10).GT.TT(NINT(TT(K+1,11)),10)) THEN CALL REV(TT(K,11), TT(K+1,11)) CHANGE = .TRUE. END IF 200 CONTINUE IF (CHANGE) GO TO 190 DO 210 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 210 IF ((ISW(5).EQ.1 .AND. LQ.EQ.7) .OR. LQ.EQ.6) WRITE (LQ,99995) 210 CONTINUE DO 230 I=1,12 K = I + 12 L = I + 24 DO 220 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 220 IF ((ISW(5).EQ.1 .AND. LQ.EQ.7) .OR. LQ.EQ.7) WRITE 1 (LQ,99994) I, (IN(NINT(TT(I,11)), J), J=1,3), 2 TT(NINT(TT(I,11)) , 10), K, (IN(NINT(TT(K,11)),J),J=1,3), 3 TT(NINT(TT(K,11)),10),L,(IN(NINT(TT(L,11)),J),J=1,3), 4 TT(NINT(TT(L,11)),10) 220 CONTINUE 230 CONTINUE I = 37 DO 240 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 240 IF ((ISW(5).EQ.1 .AND. LQ.EQ.6) .OR. LQ.EQ.7) WRITE (LQ,99993) 1 I, (IN(NINT(TT(I,11)), J), J=1,3), TT(NINT(TT(I,11)), 2 10) 240 CONTINUE * FIND 2-FOLD AXES ITEL = 0 MAXD = 0.0 DO 290 J=1,37 * TRANSFORM H,K,L, TO ORTHOGONAL COORDINATES DO 250 I=1,3 V(I) = FLOAT(IN(J,I)) 250 CONTINUE CALL SMATVEC(ROT, V, TAU) TC(1) = TAU(2)*TAU(2) + TAU(3)*TAU(3) TC(2) = TAU(1)*TAU(1) + TAU(3)*TAU(3) TC(3) = TAU(1)*TAU(1) + TAU(2)*TAU(2) TC(4) = -2*TAU(1)*TAU(2) TC(5) = -2*TAU(1)*TAU(3) TC(6) = -2*TAU(2)*TAU(3) DO 280 K=1,37 DOT = 0 DO 260 N=1,3 DOT = DOT + ABS(IN(J,N)*IN(K,N)) 260 CONTINUE IF (DOT.GE.3 .OR. DOT.LE.0) GO TO 280 TAND = TT(K,4)*TC(1) + TT(K,5)*TC(2) + TT(K,6)*TC(3) + 1 TT(K,7)*TC(4) + TT(K,8)*TC(5) + TT(K,9)*TC(6) IF (DOT.EQ.2) TAND = TAND/4.0 TAND = ATAN(SQRT(ABS(TAND)))/PAR(1) IF (TAND.GT.PAR(2)) GO TO 280 * *** HANDLE TO MANY AXES CASE IF (ITEL.EQ.15) THEN * *** FIRST RANK ACCORDING TO AXIAL LENGTH NS = 8 CALL LEPAG08(AXES, NS, ITEL) * *** AND RANK ACCORING TO TAND (ANGLE DEVIATION) NS = 7 CALL LEPAG08(AXES, NS, ITEL) ITEL = 8 END IF ITEL = ITEL + 1 DO 270 I=1,3 AXES(ITEL,I) = IN(K,I) AXES(ITEL,I+3) = IN(J,I) AXES(ITEL,I+9) = TT(K,I)/TT(K,10) 270 CONTINUE AXES(ITEL,7) = TAND AXES(ITEL,8) = TT(K,10) AXES(ITEL,9) = DOT IF (TAND.GT.MAXD) MAXD = TAND 280 CONTINUE 290 CONTINUE * ANALYSE RESULTS IN TERMS OF LATTICE TYPE AND TRANSFORMATION IF (ITEL.GT.9) THEN * *** AVOID MORE THAN 9 AXES CASE; RANK ON TAND NS = 7 CALL LEPAG08(AXES, NS, ITEL) ITEL = 9 END IF NTEL = ITEL IF (ISW(5).EQ.1) WRITE (LH,99992) NTEL, MAXD WRITE (LP,99992) NTEL, MAXD ITELX = 0 300 ISDET = 1 IF (NRI.GT.(ISKP+1)) ISDET = 2 IF (NRI.GT.(ISKP+8)) ISDET = 3 IF (NRI.GT.(ISKP+21)) ISDET = 4 NS = 7 * SORT ON TAND; THE LARGEST DELTAS ARE ELIMINATED IN THE NEXT PASSES CALL LEPAG08(AXES, NS, ITEL) * RESTORE TRANSFORMATION MATRIX; INPUT TO REDUCED CELL DO 320 I=1,3 DO 310 J=1,3 TP(I,J) = TPS(I,J) 310 CONTINUE 320 CONTINUE ITEL = ITEL - ITELX IF (ITEL.LT.3) GO TO 350 330 IF (MOD(ITEL,2).EQ.1) GO TO 340 ITEL = ITEL - 1 GO TO 330 340 NS = 8 * SORT ON AXIAL LENGTH * => IN CASE OF TWO AXES: 'FIRST THE LARGEST DELTA' IF (ITEL.GT.2) CALL LEPAG08(AXES, NS, ITEL) * CALCULATE INTERAXIAL ANGLES 350 IF (ITEL.NE.0) CALL LEPAG05(ITEL, ANGMN, ANGM) * ANALYSE RESULTS CALL LEPAG03(ITEL, NTEL, ANGM, ANGMN, MAXD) ITELX = 1 IF ((ITEL.GT.0) .AND. (MAXD.GT.PAR(3))) GO TO 300 RETURN 99999 FORMAT (//14X, 'LATT', 4X, 'A', 7X, 'B', 7X, 'C', 7X, 'ALF', 5X, 1 'BET', 5X, 'GAM', 6X, 'VOL'/1X, 75(1H-)) 99998 FORMAT (' INPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2) 99997 FORMAT (' PRIM. CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2) 99996 FORMAT (' REDUC CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), 1 F9.2////' TRANFORMATION MATRIX: INPUT TO REDUCED CELL', 9X, 2 'NIGGLI MATRIX'/1X, 75(1H=)/' (A'') (', 3(F5.2), ') (A)', 3 20X, '(A.A,B.B,C.C/B.C,A.C,A.B)'/' (B'') = (', 3(F5.2), 4 ') (B).', 17X, 3(F9.3)/' (C'') (', 3(F5.2), ') (C)', 18X, 5 3(F9.3)//) 99995 FORMAT (/' SORTED AXIAL LENGTH OF THE REDUCED CELL'/3X, 39(1H-)/ 1 ) 99994 FORMAT (3(2X, I2, 2X, 3(I3), 2X, F7.3, 3X)) 99993 FORMAT (56X, I2, 2X, 3(I3), 2X, F7.3) 99992 FORMAT (///2X, 75(1H=)/8X, '=> => =>', 8X, 'FOUND ---', I2, 1 ' --- POSSIBLE 2-FOLD AXES'/19X, ' MAX. DELTA: ', F5.3/1X, 2 75(1H=)/) END * *** SUBROUTINE LEPAG02(LOUT, VERSION) CHARACTER VERSION*10, DATUM*10, TIJD*10 COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET CALL DATE(DATUM) CALL TIME(TIJD) IF (LOUT.LT.0) GO TO 10 IF (LOUT.EQ.7) THEN * OUTPUT HEADER. WRITE (LOUT,99999) (ITLE(I),I=1,75), DATUM, TIJD, VERSION ELSE WRITE (LOUT,99998) (ITLE(I),I=1,75), VERSION END IF WRITE (LOUT,99997) IF (LOUT.NE.7) GO TO 20 WRITE (LOUT,99992) 10 LOUT = IABS(LOUT) WRITE (LOUT,99996) WRITE (LOUT,99995) WRITE (LOUT,99994) IF (LOUT.EQ.6) WRITE (LOUT,99992) WRITE (LOUT,99993) 20 CONTINUE RETURN 99999 FORMAT ('1', 4(/), 4X, 75A1/1X, 70(1H*)/' *', 68X, '*'/' *', 68X, 1 '*'/' *', 68X, '*'/' *', 21X, '---- L E P A G E ----', 22X, 2 '*'/' *', 27X, ' = = = = = = ', 28X, '*'/' *', 68X, '*'/' *', 3 68X, '*'/' *', 68X, '*'/' *', 21X, 25(1H=), 22X, '*'/' *', 21X, 4 A10, 4X, A10, 23X, '*'/' *', 21X, 25(1H=), 22X, '*'/' *', 68X, 5 '*'/2(' *', 68X, '*'/), ' *', 68X, '*'/' ', 69(1H*), '*'/' *', 6 1X, 12(1H*, 1X), ' L E P A G E ', 14(1H*, 1X)/' *', 69(1H*)/ 7 ' *', 68X, '*'/' *', 4X, 'PROGRAM TO DETERMINE THE METRICAL SY', 8 'MMETRY OF A GIVEN LATTICE', 3X, '*'/' *', 68X, '*'/' *', 12X, 9 'BASIC:', 12X, 'A.L. SPEK, UTRECHT, JAN. 1985.', 7X, '*'/' *', * 8X, 'FORTRAN V:', 11X, 'A. MEETSMA, GRONINGEN, OCT. 1985.', 6X, 1 '*'/' *', 68X, '*'/' *', 69(1H*)/' *', 68X, '*'/' *', 5X, 2 ' LATTICE SYMMETRY DETERMINATION (VERSION', A10, ' - AM)', 5X, 3 '*'/' *', 68X, '*'/' *', 69(1H*), 5(/)/8X, 'REFERENCES:'/6X, 4 60(1H=)/8X, 'Y. LEPAGE, J. APPL.CRYST. (1982). 15, 255-259.'/8X, 5 'W. CLEGG, ACTA CRYST. (1981). A37, 913-915.'/8X, 'I. KRIVY & ', 6 'B. GRUBER, ACTA CRYST. (1976). A32, 297-298.'/8X, 'MIGHELL, J', 7 '. APPL. CRYST. (1976). 9, 491-498.', 9X/6X, 60(1H=), 6(/), '1'// 8 ) 99998 FORMAT (4X, 75A1/' * ', 67(1H=), ' *'/' *', 69(1H ), '*'/' * ', 1 ' M E T R I C A L S Y M M E T R Y D E T E R M I', 2 ' T I O N *'/' * = = = = = = = = = = = = = = =', 3 ' = = = = = = = = = = = = *'/' *', 69(1H ), '*'/' * ', 4 67(1H*), ' *'/' * ***** NOTICE ***** EXPERIMENTAL VERSION, MA', 5 'Y CONTAIN ERRORS ****** *'/' * ', 67(1H*), ' *'/' *', 50(1H ), 6 'VERSION:', A10, ' *'/' *', 68(1H ), ' *'/' *', 15X, '***** L ', 7 'E P A G E *****', 30X, ' *'/' *', 21X, '= = = = = =', 36X, ' *'/ 8 ) 99997 FORMAT (/3X, 'KEYWORDS:', /, 1 7X, '- MANUAL - THIS MANUAL'/7X, '- HELP ', 1 ' - DESCRIPTION OF LEPAGE'/7X, '- TITL - TITLE TEXT ' 2 /7X, '- CRIT - CRITICAL ANGLE'/7X, '- METR -', 3 ' ANGLE OF CLASSIFICATION METRICAL'/7X, '- SUB - SE', 4 'ARCH IN SUB-LATTICES'/7X, '- SUPER - SEARCH IN SUP', 5 'ER-LATTICES'/7X, '- CELL/DATA - CELL PARAMETERS: A, B,', 6 ' C, ALF, BET AND GAM'/24X, ' (LATTYPE OR LATNR.)'/7X, '- LAT', 7 'T - LATTICE TYPE: P/I/R/F/A/B/C/X '/7X, '- TEST', 8 ' - NUMBER OF TEST CELL FROM LEPAGE_LIS'/7X, '- TRMX ', 9 ' - TRANSFORMATION MATRIX: T11, T12, T13, T21.....T23,', * ' T33'/7X, '- TRAN - TRANSF. OF INPUT CELL: T11, T', 1 '12, T13, T21.....T23, T33'/7X, '- NOSCREEN - NO OUTPUT ', 2 'ON THE SCREEN: TOGGLE (OR WITH ON/OFF)'/7X, '- PRINT ', 3 '- A HARD COPY OUTPUT: TOGGLE (OR WITH ON/OFF)'/7X, 4 '- MORE - MORE OUTPUT ON THE SCREEN: TOGGLE (OR WI', 5 'TH ON/OFF)'/7X, '- LIST - LIST FLAGS AND (INPUT)-CELL'/ 6 7X, '- CALC - START OF CALCULATION'/7X, '- QUIT/END', 7 ' - FINSH OF THE JOB'/7X, '- STOP - BREAK EXE', 8 'CUTION PREMATURELY'//) 99996 FORMAT (' ...THE PROGRAM LEPAGE ANALYSES A TRANSLATION ', 1 'LATTICE AS SUPPLIED BY'/' THE USER [A,B,C,ALFA,BETA,GAMMA', 2 ' AND LATTICE (P,A,B,C,F,R,I,X)] '/' FOR ITS METRICAL ', 3 'SYMMETRY [A = ANORTHIC, M = MONOCLINIC, O = ORTHORHOMBIC, '/ 4 ' T = TETRAGONAL, R = RHOMBOHEDRAL, H = HEXAGONAL, C = CUBI', 5 'C] '/' AND CENTERING TYPE (P,A,B,C,F,R,I).'//' THE ALGORITH', 6 'MS FOR THE CELL REDUCTION AND SYMMETRY DETERMINATION ARE'/ 7 ' BASED ON THOSE OF I.KRIVY & B. GRUBER (ACTA CRYST. (1976', 8 '). A32, 297-298.)'/' AND Y. LE PAGE (J. APPL. CRYST. (1982).', 9 ' 15, 255-259.) RESP..'//' THE ANALYSIS IN TERMS OF PSEUDO ', * 'OR METRIC SYMMETRY IS BASED ON'/' THE VALUE OF THE EXPERI', 1 'MENTAL ERROR (USE - OPTION TO CHANGE THIS VALUE).') 99995 FORMAT (' ...THE PROGRAM SEARCHES FOR TWO-FOLD AXES OF THE RE', 1 'DUCED LATTICE WITH'/' THE PROPERTY OF COINCIDING DIRECT AND', 2 ' RECIPROCAL LATTICE VECTORS. '/' IN VIEW OF EXPERIMENTAL ', 3 'ERROR, A SMALL ANGULAR RANGE OF COINCIDENCE '/' SHOULD ', 4 'BE CONSIDERED (USE - OPTION TO CHANGETHIS VALUE).'/ 5 ' THE CORRESPONDING PARAMETER MAY BE SET TO A VALUE AS CRI', 6 'TICAL AS THE ASSUMED '/' MAXIMUM EXPERIMENTAL ERROR OR TO', 7 ' A SOMEWHAT HIGHER ANGLE TO CATCH CASES OF '/' PSEUDO-SYM', 8 'METRY AND POSSIBLE TWINNING. (MAXIMUM ALLOWED VALUE = ', 9 '5 DEGREES.)'/' THE SYMMETRY OF A CELL BASED ON COINCIDENCE ANG', * 'LES LESS THAN THE '/' EXP. ERROR IS MARKED AS METRICAL, O', 1 'THERWISE PSEUDO. '/) 99994 FORMAT (' >>>>>>>>>>FOM INDICATES THE POOREST FIT. (IN DEGR', 1 'EES.)<<<<<<<<<<<<'//' THE PROGRAM CONTAINS THE DATA FOR A ', 2 'NUMBER OF LATTICES THAT MAY BE CALLED'/' WITH THE ', 3 ' - OPTION. ONE MAY BE CHOOSEN BY NR. (1-42).'/' 0 GIVES A ', 4 'FULL TEST FOR ALL SETS'/' -1 IN ADDITION LOOPS OVER ALL ', 5 'SUPERCELLS AND'/' -2 OVER ALL SUBCELLS.'//' USE / - OPTION TO INPUT USER DATA'/' OPTIONALLY PRECEDED BY:', 7 ' , , OR SETTINGS.') 99993 FORMAT (/' THE - OPTION GENERATES TRANSFORMATION ', 1 'MATRICES WITH DETERMINANT '/' 1, <=2, <=3 OR <=4 TO BE APPL', 2 'IED TO THE PRIMITIVE CELL BEFORE REDUCTION, '/' IN ORDER ', 3 'TO SEARCH FOR HIGHER SYMMETRY IN A SUPER-LATTICE. SIM', 4 'ILARLY THE'/' - OPTION MAY BE USED FOR THE SYMMETRY', 5 ' SEARCH IN SUB-LATTICES.'/' OTHER TRANSFORMATIONS ARE POSSIBL', 6 'E WITH THE [X]-MATRIX TO BE APPLIED TO'/' THE INPUT CELL', 7 ' OF THE / - OPTION.'//' :'/' THIS OP', 8 'TION ALLOWS THE SEARCH FOR SYMMETRY IN SUPER CELLS (SEE'/ 9 ' MIGHELL, J. APPL. CRYST. 9, (1976). 491). THE PROGRAM CO', * 'NTAINS 7'/' MATRICES WITH DETERMINANT 2 AND 13 WITH DETER', 1 'MINANT 3 AND 35 WITH'/' DETERMINANT 4 TO BE APPLIED ON THE PR', 2 'IMITIVE CELL BEFORE REDUCTION.'//' :'/' THIS OPT', 3 'ION ALLOWS THE SEARCH FOR SYMMETRY IN SUB CELLS (SEE'/' MIGHE', 4 'LL, J. APPL. CRYST. 9, (1976). 491). THE PROGRAM CONTAINS 7'/ 5 ' MATRICES WITH DETERMINANT 1/2 AND 13 WITH DETERMINANT 1', 6 '/3 AND 35 WITH'/' DETERMINANT 1/4 TO BE APPLIED ON THE PR', 7 'IMITIVE CELL BEFORE REDUCTION.') 99992 FORMAT (///) END * *** SUBROUTINE LEPAG03(ITEL, NTEL, ANGM, ANGMN, MAXD) * ANALYSE OF THE RESULT REAL MAXD, AA(3,3), BB(3,3) CHARACTER LAT*1, LATT*1, LAT0*1, LOOPT*5, CDET*5, TESTOK*5 CHARACTER SYST0*10, SYST*12 COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET EQUIVALENCE (TM,AA) LATT(3) = 'P' MAXD = 0.0 NR = 0 IF (ITEL.LT.1) GO TO 20 DO 10 JJ=1,ITEL IF (AXES(JJ,7).GT.MAXD) MAXD = AXES(JJ,7) 10 CONTINUE GO TO (50, 50, 140, 570, 220, 570, 330, 570, 340) ITEL * TRICLINIC 20 SYST = 'TRICLINIC' LAT0 = 'A' DO 40 N1=1,3 DO 30 N2=1,3 VAL0 = 0 IF (N1.EQ.N2) VAL0 = 1 TM(N1,N2,1) = VAL0 30 CONTINUE 40 CONTINUE GO TO 370 * MONOCLINIC 50 SYST = 'MONOCLINIC' LAT0 = 'M' * *** MAKE THE 2-AXIS THE MONOCLINIC-B AXIS DO 60 N=1,3 TM(2,N,1) = AXES(ITEL,N) 60 CONTINUE * *** LOOK FOR TWO ADDITIONAL SHORTEST VECTORS PERPENDICULAR * *** TO 2-AXIS. YDUM = COS(PAR(1)*(90-PAR(2))) D1 = 999.0 DO 90 K=1,37 DUM = (TT(K,1)*AXES(ITEL,10)+TT(K,2)*AXES(ITEL,11)+TT(K,3)* 1 AXES(ITEL,12))/TT(K,10) IF (ABS(DUM).GT.YDUM) GO TO 90 IF (TT(K,10).GE.D1) THEN IF (TT(K,10).GT.D2) GO TO 90 I = 3 D2 = TT(K,10) ELSE D2 = D1 DO 70 N=1,3 TM(3,N,1) = TM(1,N,1) CL(3,N) = CL(1,N) 70 CONTINUE I = 1 D1 = TT(K,10) END IF DO 80 N=1,3 TM(I,N,1) = IN(K,N) CL(I,N) = TT(K,N) 80 CONTINUE 90 CONTINUE * MAKE BETA > 90 DUM = CL(1,1)*CL(3,1) + CL(1,2)*CL(3,2) + CL(1,3)*CL(3,3) IF (DUM.LT.0) GO TO 110 DO 100 N=1,3 TM(3,N,1) = -TM(3,N,1) 100 CONTINUE 110 CALL SMINV(AA, BB, DET) IF (DET.GT.0) GO TO 370 DO 120 N=1,3 TM(2,N,1) = -TM(2,N,1) 120 CONTINUE GO TO 370 * ORTHORHOMBIC 130 SYST = 'ORTHORHOMBIC' LAT0 = 'O' ZANG = 90 GO TO 240 * RHOMBOHEDRAL 140 SYST = 'RHOMB.(OBV.)' IF ((ANGM.GT.(120+PAR(2))) .OR. (ANGMN.LT.(120-PAR(2)))) GO TO 130 LAT0 = 'H' DOT = 0.0 K = 0 DO 160 I3=1,3,2 K = K + 1 DO 150 J3=1,3 TM(K,J3,1) = AXES(I3,J3) CL(K,J3) = AXES(I3,J3+9) IF (K.EQ.2) DOT = DOT + CL(1,J3)*CL(2,J3) 150 CONTINUE 160 CONTINUE IF (DOT.LT.0) GO TO 180 DO 170 J3=1,3 TM(2,J3,1) = -TM(2,J3,1) CL(2,J3) = -CL(2,J3) 170 CONTINUE * CALCULATE THIRD AXIS PERP TO 1 AND 2 180 CRS1 = CL(1,2)*CL(2,3) - CL(1,3)*CL(2,2) CRS2 = CL(1,3)*CL(2,1) - CL(1,1)*CL(2,3) CRS3 = CL(1,1)*CL(2,2) - CL(1,2)*CL(2,1) TM(3,1,1) = CRS1*ROT(1,1) + CRS2*ROT(2,1) + CRS3*ROT(3,1) TM(3,2,1) = CRS1*ROT(1,2) + CRS2*ROT(2,2) + CRS3*ROT(3,2) TM(3,3,1) = CRS1*ROT(1,3) + CRS2*ROT(2,3) + CRS3*ROT(3,3) CALL SMINV(AA, BB, DET) DO 190 N=1,3 TMDUM = TM(3,N,1)*3/DET TM(3,N,1) = NINT(TMDUM) 190 CONTINUE * TEST FOR OBVERSE SETTING LOOP = 0 200 IF (LOOP.EQ.2) GO TO 530 * ONLY ONCE THROUGH THE LOOP; IF TWICE THEN EXIT!! MODL = 3 H(1) = 2 H(2) = 1 H(3) = 1 CALL LEPAG07(MODL, H, TM, NUM) IF (NUM.EQ.0) GO TO 370 DO 210 N=1,3 TM(1,N,1) = -TM(1,N,1) TM(2,N,1) = -TM(2,N,1) 210 CONTINUE LOOP = LOOP + 1 GO TO 200 * TETRAGONAL 220 SYST = 'TETRAGONAL' LAT0 = 'T' * ENTRY POINT FOR HEXAGONAL 230 ZANG = (ITEL+1)*15 * ENTRY POINT FOR ORTHORHOMBIC 240 N90 = ITEL - 1 IOK = 0 DO 250 I=1,ITEL IF (NINT(AXES(I,13)).NE.N90) GO TO 250 IOK = 1 250 CONTINUE IF (IOK.EQ.0) GO TO 530 YDUM1 = COS((ZANG-PAR(2))*PAR(1)) YDUM2 = COS((ZANG+PAR(2))*PAR(1)) K = 0 DO 300 I3=1,ITEL IF (NINT(AXES(I3,13)).LT.2) GO TO 530 IF (ITEL.GT.3) GO TO 260 K3 = I3 GO TO 280 260 IF (NINT(AXES(I3,13)).NE.N90) GO TO 270 K3 = 3 GO TO 280 270 K = K + 1 IF (K.GT.2) THEN K3 = 0 ELSE K3 = K END IF * SAVE THE AXIAL INDICES 280 IF (K3.GT.0) THEN DO 290 J3=1,3 TM(K3,J3,1) = AXES(I3,J3) CL(K3,J3) = AXES(I3,J3+9) 290 CONTINUE END IF 300 CONTINUE DUM = CL(1,1)*CL(2,1) + CL(1,2)*CL(2,2) + CL(1,3)*CL(2,3) IF (DUM.LT.0.0) GO TO 320 DO 310 N=1,3 TM(2,N,1) = -TM(2,N,1) 310 CONTINUE DUM = -DUM 320 IF ((DUM.GT.YDUM1) .OR. (DUM.LT.YDUM2)) GO TO 530 GO TO 370 * HEXAGONAL 330 SYST = 'HEXAGONAL' LAT0 = 'H' GO TO 230 * CUBIC 340 SYST = 'CUBIC' LAT0 = 'C' K3 = 0 N90 = 4 * *** LOAD THE THREE FOUR-FOLD AXES INDECES IN TM DO 360 I3=1,9 IF (NINT(AXES(I3,13)).EQ.N90) THEN K3 = K3 + 1 IF (K3.LE.3) THEN DO 350 J3=1,3 TM(K3,J3,1) = AXES(I3,J3) 350 CONTINUE END IF END IF 360 CONTINUE IF (K3.NE.3) GO TO 530 ***************************************************************** * **************** F I N D L A T T I C E T Y P E *********** * ************************************************************** 370 CONTINUE CALL SMINV(AA, BB, DET) IF (DET.LT.0) THEN DO 380 N=1,3 TM(3,N,1) = -TM(3,N,1) 380 CONTINUE END IF IDET = NINT(ABS(DET)) IF (IDET.NE.2) THEN IF (IDET.EQ.3) LATT(3) = 'R' IF (IDET.EQ.4) LATT(3) = 'F' ELSE * TEST FOR A MODL = 2 LATT(3) = 'A' H(1) = 0 H(2) = 1 H(3) = 1 CALL LEPAG07(MODL, H, TM, NUM) IF (NUM.EQ.0) GO TO 390 * TEST FOR B LATT(3) = 'B' H(1) = 1 H(2) = 0 H(3) = 1 CALL LEPAG07(MODL, H, TM, NUM) IF (NUM.EQ.0) GO TO 390 * TEST FOR C LATT(3) = 'C' H(1) = 1 H(2) = 1 H(3) = 0 CALL LEPAG07(MODL, H, TM, NUM) IF (NUM.EQ.0) GO TO 390 * TEST FOR I LATT(3) = 'I' H(1) = 1 H(2) = 1 H(3) = 1 CALL LEPAG07(MODL, H, TM, NUM) IF ((NUM.NE.0) .OR. (IDET.GT.4)) THEN WRITE (LH,99988) STOP 'STOPPED: "WRONG DETERMINANT!"' END IF 390 CONTINUE END IF ************************************************************************ IF ((ITEL.LT.3) .AND. (LATT(3).EQ.'A')) THEN DO 400 N=1,3 CALL REV(TM(1,N,1), TM(3,N,1)) TM(2,N,1) = -TM(2,N,1) 400 CONTINUE LATT(3) = 'C' END IF IF ((ITEL.EQ.3) .AND. ((LATT(3).EQ.'A') .OR. (LATT(3).EQ.'B'))) 1 THEN IF (LATT(3).EQ.'A') THEN DO 410 N=1,3 CALL REV(TM(1,N,1), TM(3,N,1)) CALL REV(TM(1,N,1), TM(2,N,1)) 410 CONTINUE ELSE DO 420 N=1,3 CALL REV(TM(2,N,1), TM(3,N,1)) TM(1,N,1) = -TM(1,N,1) 420 CONTINUE END IF LATT(3) = 'C' END IF IF (ITEL.GT.0) CALL LEPAG06(ITEL) L = 1 CALL LEPAG04(L) CALL SMINV(TP, TG, DETM) SYST0 = 'METRICALLY' IF (MAXD.GT.PAR(3)) SYST0 = 'PSEUDO' IF (NR.EQ.8) THEN DO 430 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 430 WRITE (LQ,99995) ((TX(I,J),J=1,3),I=1,3) 430 CONTINUE END IF DO 440 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 440 WRITE (LQ,99999) WRITE (LQ,99998) (TP(1,J),J=1,3), (TG(J,1),J=1,3), SYST0 WRITE (LQ,99997) (TP(2,J),J=1,3), (TG(J,2),J=1,3), SYST WRITE (LQ,99996) (TP(3,J),J=1,3), (TG(J,3),J=1,3), MAXD 440 CONTINUE DO 460 I3=1,3 DO 450 J3=1,3 G(I3,J3) = GI(I3,J3) 450 CONTINUE 460 CONTINUE CALL TRMETR(G, TP) CALL NEWCON(G, CELL) CELL(7) = VOLUME(CELL) DO 470 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 470 WRITE (LQ,99994) WRITE (LQ,99993) LATT(1), (OCELL(J),J=1,7), LATT(2), 1 (RCELL(I),I=1,7) 470 CONTINUE TESTOK = ' ' IF (ISW(9).NE.0) THEN TOK = 0.0 DO 480 I=1,6 TOK = TOK + ABS(CELL(I)-TCELL(I)) 480 CONTINUE IF (TOK.LT.0.5 .AND. LATT(3).EQ.LATT(4)) TESTOK = ' O.K.' DO 490 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 490 WRITE (LQ,99992) LAT0, LATT(3), (CELL(J),J=1,7), TESTOK 490 CONTINUE ELSE DO 500 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 500 WRITE (LQ,99991) LAT0, LATT(3), (CELL(J),J=1,7) 500 CONTINUE END IF IF (NRS.GT.(ISKP+1)) THEN NP = NRI - ISKP DO 510 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 510 WRITE (LQ,99990) LOOPT, NP, ((TM(I,J,NRI),J=1,3),I=1,3), 1 CDET, ISDET 510 CONTINUE END IF IF (SYST0(1:1).EQ.'M') THEN DO 520 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 520 WRITE (LQ,99989) 520 CONTINUE END IF RETURN 530 IF (ITEL.GT.0) CALL LEPAG06(ITEL) IF (ITEL.NE.NTEL) THEN IF (ITEL.EQ.(NTEL-1)) THEN DO 540 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 540 WRITE (LQ,99987) SYST 540 CONTINUE ELSE DO 550 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 550 WRITE (LQ,99986) SYST 550 CONTINUE END IF ELSE DO 560 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 560 WRITE (LQ,99985) SYST 560 CONTINUE END IF RETURN 570 STOP ' WRONG "ITEL" NUMBER ' 99999 FORMAT (//' === TRANSFORMATION MATRIX: INPUT (A,B,C) TO CON', 1 'VENTIONAL CELL(A'', B'', C'') === '/1X, 77(1H=)) 99998 FORMAT (' (A'') (', 3(F5.2), ') (A) (X'') (', 3(F5.2), 1 ') (X) ', 10(A)) 99997 FORMAT (' (B'') = (', 3(F5.2), ') (B). (Y'') = (', 3(F5.2), 1 ') (Y). ', 21(A)) 99996 FORMAT (' (C'') (', 3(F5.2), ') (C) (Z'') (', 3(F5.2), 1 ') (Z) FOM: ', F5.3/) 99995 FORMAT (' SPECIAL [X] = (', 2(3F6.2, ' /'), 3F6.2, ')') 99994 FORMAT (/13X, 'LAT0', 1X, 'LATT', 3X, 'A', 7X, 'B', 7X, 'C', 7X, 1 'ALFA', 4X, 'BET', 5X, 'GAM', 7X, 'VOL'/1X, 79(1H-)) 99993 FORMAT (' INPUT CELL ', 5X, 1A1, 3(1X, F7.3), 3(2X, F6.2), 1X, 1 F9.2/1X, ' REDUC CELL ', 5X, 1A1, 3(1X, F7.3), 3(2X, F6.2), 2 1X, F9.2) 99992 FORMAT (' CONV. CELL ', 1A, 4X, 1A, 3(1X, F7.3), 3(2X, F6.2), 1 1X, F9.2/69X, 1A5/1X, 79(1H-)) 99991 FORMAT (' CONV. CELL ', 1A, 4X, 1A, 3(1X, F7.3), 3(2X, F6.2), 1 1X, F9.2/1X, 79(1H-)) 99990 FORMAT (2X, A5, ' TRANSF:', I3, ' (', 2(3F5.1, '/'), 3F5.1, ') ', 1 A5, ' = ', I2) 99989 FORMAT (1X, 79(1H=)/) 99988 FORMAT (//' THERE IS SOMETHING WRONG IN TYPE ANALYSIS') 99987 FORMAT (/' AFTER DELETING THE LAGERST DELTA:', 2X, '=> =>', 1 ' NOT EVEN PSEUDO ', A12/) 99986 FORMAT (/' AFTER DELETING THE TWO LAGERST DELTAS:', 2X, '=> =', 1 '> NOT EVEN PSEUDO ', A12/) 99985 FORMAT (/11X, '=> => => NOT EVEN PSEUDO ', A12/) END * *** SUBROUTINE LEPAG04(L) * ACCUMULATE TRANSFORMATIONS [TP(NEW)] = [TM(L)] * [TP(OLD)](3,3) COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET * FIRST COPY OLD [TP] INTO [TG] DO 20 I=1,3 DO 10 J=1,3 TG(I,J) = TP(I,J) 10 CONTINUE 20 CONTINUE DO 50 I=1,3 DO 40 J=1,3 TP(I,J) = 0 DO 30 K=1,3 TP(I,J) = TP(I,J) + TM(I,K,L)*TG(K,J) 30 CONTINUE 40 CONTINUE 50 CONTINUE RETURN END * *** SUBROUTINE LEPAG05(ITEL, ANGMN, ANGM) * CALCULATE INTERAXIAL ANGLES COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET ANGM = 0.0 ANGMN = 180.0 DO 20 I=1,ITEL AXES(I,13) = 0.0 DO 10 J=1,ITEL ANG = 0.0 AXES(I,J+13) = 0.0 IF (I.EQ.J) GO TO 10 ANG = AXES(I,10)*AXES(J,10) + AXES(I,11)*AXES(J,11) + 1 AXES(I,12)*AXES(J,12) IF (ABS(ANG).LT..00001) THEN ANG = 90.0 ELSE IF (ANG.GE.1.0) THEN ANG = 0 ELSE ANG = ACOS(ANG)/PAR(1) IF (ANG.LT.0.0) ANG = ANG + 180.0 IF (ANG.LT.90.0) ANG = 180.0 - ANG END IF IF (ANG.GT.ANGM) ANGM = ANG IF (ANG.LT.ANGMN) ANGMN = ANG AXES(I,J+13) = ANG * SEACH 4- AND 6-AXES IF (((ANG+PAR(2)).GT.90) .AND. ((ANG-PAR(2)).LT.90)) 1 AXES(I,13) = AXES(I,13) + 1 10 CONTINUE 20 CONTINUE RETURN END * *** SUBROUTINE LEPAG06(ITEL) COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET DO 10 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 10 WRITE (LQ,99999) 10 CONTINUE DO 30 LQ=6,7 IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 30 DO 20 I=1,ITEL WRITE (LQ,99998) I, AXES(I,8), NINT(AXES(I,13)) , 1 (NINT(AXES(I,K)), K=1,6), NINT(AXES(I,9)) , 2 AXES(I,7), (AXES(I,13+J),J=1,ITEL) 20 CONTINUE 30 CONTINUE RETURN 99999 FORMAT (///31X, 'POSSIBLE 2-FOLD AXES'/31X, 20(1H-)/29X, 'ROWS', 1 16X, 'PRODUCTS'/' NR', 5X, 'D', 7X, 'N', 5X, 'DIRECT', 6X, 2 'RECIPROCAL', 4X, 'DOT DELTA', 9X, 'ANGLE BETWEEN TWO ', 3 'DIRECT AXES '/1X, 125(1H-)) 99998 FORMAT (1X, I2, 2X, F7.3, 3X, I2, 1X, 3I4, 2X, 3I4, 4X, I2, 4X, 1 F5.3, 3X, 9(1X, F6.1)) END * *** SUBROUTINE LEPAG07(MODL, H, TM, NUM) * TEST LATTICE TYPE DIMENSION H(3), TM(3,3,127) NUM = 0 DO 20 J=1,3 DM = 0.0 DO 10 I=1,3 DM = DM + H(I)*TM(I,J,1) 10 CONTINUE NUM = NUM + MOD(NINT(ABS(DM)),MODL) 20 CONTINUE RETURN END * *** SUBROUTINE LEPAG08(AXES, NS, ITEL) * BUBBLE SORT AXES REAL AXES(15,22) LOGICAL CHANGE 10 CHANGE = .FALSE. DO 30 J=1,(ITEL-1) IF (AXES(J,NS).GT.AXES(J+1,NS)) THEN DO 20 I=1,13 CALL REV(AXES(J,I), AXES(J+1,I)) 20 CONTINUE CHANGE = .TRUE. END IF 30 CONTINUE IF (CHANGE) GO TO 10 RETURN END * *** SUBROUTINE LEPAG09 CHARACTER LAT*1, LATT*1, LOOPT*5, CDET*5 COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8), 1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3), 2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10), 3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS, 4 NRI, NRSL, IDET, ISDET * LATTICE TYPE DATA (LAT(I),I=1,8) /'P','I','R','F','A','B','C','X'/ * LIST OF THE 37 LATTICE VECTORS TO BE TESTED AS TENTATIVE TWO-AXES DATA ((IN(I,J),J=1,3),I=1,37) /0,0,1,0,1,-2,0,1,-1,0,1,0,0,1,1,0, 1 1,2,0,2,-1,0,2,1,1,-2,-1,1,-2,0,1,-2,1,1,-1,-2,1,-1,-1,1,-1,0,1, 2 -1,1,1,-1,2,1,0,-2,1,0,-1,1,0,0,1,0,1,1,0,2,1,1,-2,1,1,-1,1,1,0, 3 1,1,1,1,1,2,1,2,-1,1,2,0,1,2,1,2,-1,-1,2,-1,0,2,-1,1,2,0,-1,2,0, 4 1,2,1,-1,2,1,0,2,1,1/ * TABLE OF TRANSFORMATION MATRICES USED IN THE CELL REDUCTION DATA (((TM(I,J,K),J=1,3),I=1,3),K=1,8) /0,1,0,1,0,0,0,0,-1,-1,0,0, 1 0,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,1,0,0,0, 2 1,1,0,0,0,1,0,0,0,1,1,0,0,0,1,0,0,0,1,1,0,0,0,1,0,1,1,1/ * CENTERED TO PRIMITIVE CELL TRANSFORMATION DATA (((TM(I,J,K),J=1,3),I=1,3),K=9,15) /1.,0.,0.,0.,1.,0.,0.,0., 1 1.,1.,0.,0.,0.,1.,0.,0.5,0.5,0.5,.666667,.333333,.333333, 2 -.333333,.333333,.333333,-.333333,-.666667,.333333,0.5,0.,0.5,.5, 3 .5,0.,0.,.5,.5,1.,0.,0.,0.,1.,0.,0.,.5,.5,0.5,0.,.5,0.,1.,0.,0., 4 0.,1.,1.,0.,0.,.5,.5,0.,0.,0.,1./ * *** SUPERLAT1: DATA (((TM(I,J,K),J=1,3),I=1,3),K=16,16) /1,0,0,0,1,0,0,0,1/ * *** SUPERLAT2: DATA (((TM(I,J,K),J=1,3),I=1,3),K=17,23) /2.0,0.0,0.0,0.0,1.0,0.0, 1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0, 2 1.0,0.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,2.0,0.0, 3 0.0,0.0,1.0,0.0,1.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,2.0, 4 1.0,1.0,0.0,0.0,1.0,1.0,1.0,0.0,1.0/ * * SUPERLAT3: DATA (((TM(I,J,K),J=1,3),I=1,3),K=24,36) /3.0,0.0,0.0,0.0,1.0,0.0, 1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,3.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0, 2 1.0,0.0,0.0,0.0,3.0,1.0,-1.0,0.0,2.0,1.0,0.0,0.0,0.0,1.0,1.0,1.0, 3 0.0,-2.0,1.0,0.0,0.0,0.0,1.0,-1.0,0.0,1.0,2.0,0.0,1.0,0.0,1.0, 4 0.0,1.0,0.0,1.0,2.0,0.0,-1.0,0.0,1.0,0.0,0.0,1.0,-1.0,0.0,2.0, 5 1.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,-2.0,1.0,1.0,0.0,0.0,2.0,1.0,1.0, 6 1.0,1.0,0.0,0.0,2.0,1.0,1.0,2.0,1.0,-1.0,-1.0,0.0,2.0,0.0,1.0, 7 1.0,1.0,2.0,1.0,0.0,1.0,2.0,1.0,0.0,1.0,1.0,1.0,1.0,2.0,0.0,0.0, 8 2.0,1.0/ * * SUPERLAT4: DATA (((TM(I,J,K),J=1,3),I=1,3),K=37,54) /4.0,0.0,0.0,0.0,1.0,0.0, 1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,4.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0, 2 1.0,0.0,0.0,0.0,4.0,4.0,0.0,0.0,3.0,1.0,0.0,0.0,0.0,1.0,4.0,0.0, 3 0.0,1.0,1.0,0.0,0.0,0.0,1.0,4.0,0.0,0.0,0.0,1.0,0.0,3.0,0.0,1.0, 4 4.0,0.0,0.0,0.0,1.0,0.0,1.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,3.0,0.0, 5 0.0,4.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,4.0,4.0,0.0,0.0,2.0,1.0, 6 0.0,0.0,0.0,1.0,4.0,0.0,0.0,0.0,1.0,0.0,2.0,0.0,1.0,1.0,0.0,0.0, 7 0.0,2.0,1.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,2.0,0.0,0.0,0.0,1.0,2.0, 8 0.0,0.0,0.0,1.0,0.0,1.0,0.0,2.0,1.0,0.0,0.0,0.0,1.0,2.0,0.0,0.0, 9 4.0,2.0,2.0,0.0,0.0,1.0,1.0,1.0,0.0,1.0,1.0,1.0,0.0,0.0,1.0,1.0, * 2.0,0.0,2.0,1.0,1.0,0.0,0.0,2.0,2.0,1.0,0.0,1.0/ DATA (((TM(I,J,K),J=1,3),I=1,3),K=55,71) /1.0,2.0,1.0,1.0,1.0,2.0, 1 2.0,1.0,1.0,3.0,1.0,0.0,1.0,1.0,1.0,2.0,0.0,1.0,4.0,0.0,0.0,1.0, 2 1.0,0.0,2.0,0.0,1.0,2.0,1.0,0.0,1.0,1.0,1.0,3.0,0.0,1.0,4.0,0.0, 3 0.0,2.0,1.0,0.0,1.0,0.0,1.0,1.0,1.0,1.0,0.0,1.0,3.0,1.0,0.0,2.0, 4 2.0,0.0,0.0,0.0,1.0,1.0,1.0,0.0,2.0,2.0,1.0,0.0,0.0,1.0,1.0,2.0, 5 0.0,1.0,1.0,2.0,0.0,0.0,2.0,1.0,1.0,0.0,1.0,1.0,1.0,0.0,0.0,1.0, 6 2.0,1.0,0.0,2.0,2.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,1.0,2.0,0.0,0.0, 7 0.0,1.0,0.0,0.0,0.0,2.0,1.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,2.0,2.0, 8 0.0,0.0,0.0,1.0,1.0,0.0,0.0,2.0,2.0,0.0,0.0,0.0,2.0,0.0,1.0,0.0, 9 1.0,2.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,1.0,1.0, * 0.0,0.0,2.0/ * *** SUBLAT1: DATA (((TM(I,J,K),J=1,3),I=1,3),K=72,72) /1,0,0,0,1,0,0,0,1/ * *** SUBLAT2: DATA (((TM(I,J,K),J=1,3),I=1,3),K=73,79) /0.5,0.0,0.0,0.0,1.0,0.0, 1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0, 2 1.0,0.0,0.0,0.0,0.5,0.5,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.5,0.0, 3 -0.5,0.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.5, 4 0.5,0.5,0.5,-0.5,-0.5,0.5,0.5,0.5,-0.5,0.5/ * * SUBLAT3: DATA (((TM(I,J,K),J=1,3),I=1,3),K=80,92) /0.33333,0.0,0.0,0.0,1.0, 1 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.33333,0.0,0.0,0.0,1.0,1.0,0.0, 2 0.0,0.0,1.0,0.0,0.0,0.0,0.33333,0.33333,-0.66667,0.0,0.33333, 3 0.33333,0.0,0.0,0.0,1.0,0.33333,0.66667,0.0,-0.33333,0.33333,0.0, 4 0.0,0.0,1.0,-0.33333,0.0,0.66667,0.33333,0.0,0.33333,0.0,1.0,0.0, 5 0.33333,0.0,0.66667,0.33333,0.0,-0.33333,0.0,1.0,0.0,0.0,0.33333, 6 -0.66667,0.0,0.33333,0.33333,1.0,0.0,0.0,0.0,0.33333,0.66667,0.0, 7 -0.33333,0.33333,1.0,0.0,0.0,0.33333,-0.33333,0.66667,0.33333, 8 0.66667,-1.33333,-0.33333,0.33333,0.33333,-0.33333,0.33333, 9 0.66667,-0.66667,-0.33333,1.33333,0.33333,-0.33333,0.33333, * -0.33333,0.66667,0.33333,0.66667,-1.33333,0.33333,0.33333, 1 0.33333,-0.33333,0.66667,-0.33333,0.66667,0.33333,0.33333, 2 -0.66667,-0.66667,0.33333,0.33333/ * * SUBLAT4: DATA (((TM(I,J,K),J=1,3),I=1,3),K=93,109) /0.25,0.0,0.0,0.0,1.0, 1 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.25,0.0,0.0,0.0,1.0,1.0,0.0,0.0, 2 0.0,1.0,0.0,0.0,0.0,0.25,0.25,-0.75,0.0,0.0,1.0,0.0,0.0,0.0,1.0, 3 0.25,-0.25,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.0,-0.75,0.0,1.0, 4 0.0,0.0,0.0,1.0,0.25,0.0,-0.25,0.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0, 5 0.0,0.0,1.0,0.0,0.0,-0.75,0.25,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.25, 6 0.25,0.25,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.0,-0.5,0.0,1.0, 7 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.5,0.0,0.0,-0.25,0.5,0.5,-0.25, 8 0.0,0.0,0.5,0.0,0.0,0.0,1.0,0.5,0.0,-0.25,0.0,1.0,0.0,0.0,0.0, 9 0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.5,0.25,0.25,0.25,-0.25,-0.5, * 0.5,0.5,0.5,-0.5,0.5,0.5,0.5,-0.5,-0.5,0.5,-0.25,-0.5,0.5,0.25/ DATA (((TM(I,J,K),J=1,3),I=1,3),K=110,127) /0.5,0.5,-0.5,-0.25, 1 0.25,0.25,0.5,-0.5,0.5,-0.25,0.75,-0.25,-0.25,-0.25,0.75,0.75, 2 -0.25,-0.25,0.25,0.25,-0.5,-0.25,0.75,0.5,0.25,-0.75,0.5,0.25, 3 -0.25,-0.5,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.5,-0.75,-0.25,0.5,0.75, 4 0.25,-0.5,0.25,0.25,-0.5,-0.25,0.0,1.0,0.0,0.0,0.0,1.0,0.5,0.75, 5 -0.25,-0.5,0.25,0.25,0.5,-0.75,0.25,0.5,0.25,-0.25,0.0,1.0,0.0, 6 0.0,-0.5,0.5,0.25,0.5,-0.5,-0.25,0.5,0.5,0.25,-0.5,0.5,0.5,0.25, 7 -0.5,-0.5,0.25,0.5,0.5,-0.25,0.5,0.5,-0.5,0.5,0.5,0.5,-0.5,-0.25, 8 0.25,0.25,0.5,0.0,0.0,0.0,0.5,0.0,0.0,0.0,1.0,0.5,0.0,0.0,0.0, 9 1.0,0.0,0.0,0.0,0.5,1.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0,0.5,0.5,0.0, * 0.0,0.0,1.0,0.0,0.0,-0.5,0.5,0.5,0.0,-0.5,0.0,0.5,0.0,0.0,0.0, 1 1.0,0.5,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,0.5,0.5,-0.5,0.0,0.0,1.0, 2 0.0,0.0,-0.5,0.5/ RETURN END SUBROUTINE FRDA(ICL, IFL, FN, KL, KN, NCHAR, IMIN, IMAX) * ********************************************************************** * * * * THE FIRST INPUT LINE BEGINS WITH A KEYWORD IN THE FIRST NON-BLANK * * COLUMN. * * CONCATENATION LINES BEGINS WITH A DOLLAR SIGN ($) IN THE FIRST * * COLUMN (OR THE FOREGOING LINE ENDS WITH A EQUAL SIGN(=)) * * ALWAYS FIRST READ THE KEYWORD AND THEN ZERO, ONE OR MORE ITEM * * FIELDS BELONGING TO THE KEYWORD. * * IN IFL(II,NL) ONE WILL FIND THE FIRST NUMBER OF THE NUMERIC * * FIELD BELONGING TO THE KEYWORD IN THE ARRAY ELEMENTS: * * IFL(II,1) TOO IFL(II,NL-1). * * => => THE TOTAL NUMERIC FIELDS BELONGING TO THE KEYWORD IS: * * IFL((II+1),NL) - IFL(II,NL); NOTE THIS CAN BE ZERO!! * * IF IFL((II+1),NL).EQ.0 THEN THE FIRST TERM IN THE AFORE NAMED * * DIFFERENCE MUST BE REPLACED BY THE MAXIMUN NUMERIC FIELD * * PLUS ONE ( = KN + 1 !!!!!!!) * * => BEGIN OF A LITERAL FIELD DEFINED BY A BLANK( ). * * => END OF A LITERAL FIELD DEFINED BY A BLANK( ) OR A COMMA(,). * * => BEGIN OR END OF A NUMERIC FIELD * * DEFINED BY A BLANK( ), PLUS(+) OR MINUS(-). * * * * * => => THE COMMA(,) 'BETWEEN' ITEMS ON THE INPUT LINE REACTS * * AS A FIELD DELIMITER! * * * * * ********************************************************************** * MODIFIED: 15 SEPT 1986 (A.M.) * * 24 FEBR 1987 (A.M.) * * 4 JULY 1989 (A.M.) * * * COMMON /CRSET/ INUM(11), ISMB(10), LETR(53) DIMENSION ICL(80), IFL(31,7), FN(31) DATA ICH, LH /1H ,6/ DATA INUM /1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0,1H / DATA ISMB /1H ,1H+,1H-,1H.,1H(,1H),1H>,1H$,1H,,1H=/ DATA LETR /1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,1HM, 1 1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ,1H , 1 1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,1Hk,1Hl,1Hm, 1 1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,1Hu,1Hv,1Hw,1Hx,1Hy,1Hz/ * * IF (NCHAR.GT.6) NCHAR = 6 DO 7 I=1,80 N = ICL(I) DO 9 J=28,53 IF (N.EQ.LETR(J)) ICL(I) = LETR(J-27) 9 CONTINUE 7 CONTINUE IF (ICL(1).EQ.ISMB(8)) GO TO 30 IF (ICH.EQ.ISMB(10)) THEN I = 0 KL = KL - 1 GO TO 40 END IF KN = 0 KL = 0 NL = NCHAR + 1 I = IMIN - 1 DO 20 II=1,31 DO 10 JJ=1,NL-1 IFL(II,JJ) = (1H ) 10 CONTINUE IFL(II,NL) = 0 FN(II) = 0 20 CONTINUE GO TO 40 30 I = 1 * * * **** START OF A NEW FIELD * **** LOOK FOR A NON-BLANK COLUMN * * 40 A = 0.0 IP = 0 NP = 0 L = 0 S = 1.0 50 I = I + 1 IF (I.GT.IMAX) GO TO 110 ICH = ICL(I) IF (L.EQ.0 .AND. ICH.EQ.ISMB(1)) GO TO 50 * * * **** START OF A FIELD * * L = L + 1 DO 60 J=1,10 IF (ICH.EQ.INUM(J)) GO TO 70 60 CONTINUE IF (ICH.EQ.ISMB(4)) GO TO 80 IF (ICH.EQ.ISMB(2)) GO TO 90 IF (ICH.EQ.ISMB(3)) GO TO 100 IF (L.GT.1) GO TO 120 * * * **** START OF A LITERAL FIELD BY A CHARACTER WHICH IS OTHER THAN 0-9+- GO TO 130 * **** NUMERIC FIELD FOUND * * 70 IF (J.EQ.10) J = 0 IF (IP.EQ.1) NP = NP + 1 A = 10.0*A + J GO TO 50 80 IF (IP.EQ.1) GO TO 180 IP = 1 GO TO 50 90 IF (L.GT.1) GO TO 120 S = 1.0 GO TO 50 100 IF (L.GT.1) GO TO 120 S = -1.0 GO TO 50 110 IF (L.GT.0) GO TO 120 RETURN * * * **** END OF NUMERIC FIELD * * 120 IF (KL.EQ.0) GO TO 190 A = S*A/10.0**NP KN = KN + 1 IF (KN.GT.31) GO TO 200 FN(KN) = A IF (ICH.EQ.ISMB(2) .OR. ICH.EQ.ISMB(3)) I = I - 1 GO TO 40 * * * **** LITERAL FIELD * FIRST KEYWORD AND THEN EVENTUALLY THE NUMERIC FIELDS BELONGING TO IT * * 130 KL = KL + 1 IF (KL.GT.31) GO TO 210 IFL(KL,NL) = KN + 1 140 IFL(KL,L) = ICH IF (ICH.EQ.ISMB(10)) RETURN L = L + 1 150 I = I + 1 IF (I.GT.IMAX) GO TO 160 ICH = ICL(I) IF (ICH.EQ.ISMB(1) .OR. ICH.EQ.ISMB(9)) GO TO 160 IF (L-NCHAR) 140, 140, 150 160 DO 170 J=L,NCHAR IFL(KL,J) = ISMB(1) 170 CONTINUE GO TO 40 * * * **** FINISHED * * 180 CONTINUE WRITE (LH,99999) ICL STOP '- END NUMERIC FIELD BY A DOT -' 190 CONTINUE WRITE (LH,99999) ICL STOP '--- NO BEGIN WITH A KEYWORD ---' 200 CONTINUE WRITE (LH,99999) ICL STOP '--- TOO MUCH NUMERIC FIELDS ---' 210 CONTINUE WRITE (LH,99999) ICL STOP '--- TOO MUCH LITERAL FIELDS ---' 99999 FORMAT (//' THE FALSE LINE IS: '/2X, 17(1H=)//2X, 80A1///) END * *** SUBROUTINE METRIC(C, G) * CALCULATION METRIC TENSOR * *** A, B, C, ALF, BET, GAM IN [C(1)--C(6)] REAL C(10), G(3,3) DTR = ATAN(1.0)/45.0 G(1,1) = C(1)*C(1) G(2,2) = C(2)*C(2) G(3,3) = C(3)*C(3) G(1,2) = C(1)*C(2)*COS(DTR*C(6)) G(1,3) = C(1)*C(3)*COS(DTR*C(5)) G(2,3) = C(2)*C(3)*COS(DTR*C(4)) G(2,1) = G(1,2) G(3,1) = G(1,3) G(3,2) = G(2,3) RETURN END * *** SUBROUTINE NEWCON(G, C) * *** A, B, C, ALF, BET, GAM IN [C(1)--C(6)] * GET NEW A, B, C, ALF, BET, GAM FROM G * C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001. REAL C(10), G(3,3) DTR = ATAN(1.0)/45.0 C(1) = SQRT(G(1,1)) C(2) = SQRT(G(2,2)) C(3) = SQRT(G(3,3)) C(4) = ACOS(G(2,3)/(C(2)*C(3)))/DTR C(5) = ACOS(G(1,3)/(C(1)*C(3)))/DTR C(6) = ACOS(G(1,2)/(C(1)*C(2)))/DTR RETURN END * *** SUBROUTINE ORTHOG(C, OR) * *** A, B, C, ALF, BET, GAM IN [C(1)--C(6)] * C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001. DIMENSION C(10), OR(3,3) DTR = ATAN(1.0)/45.0 DO 20 I=1,3 DO 10 J=1,3 OR(I,J) = 0.0 10 CONTINUE 20 CONTINUE * *** CALCULATION OF ORTHOGONALISATION MATRIX: * *** NOW: J.D. DUNITZ, XRAY ANALYSIS AND STRUCTURE DETERMINATION OF * *** ORGANIC MOLECULES, CORNAL UNIV. PRESS, 1979, P236. * *** WAS: REF. ROLLETT COMPUTING METHODS IN CRYSTALLOGRAPHY P.23 SA = SIN(C(4)*DTR) SB = SIN(C(5)*DTR) SG = SIN(C(6)*DTR) CA = COS(C(4)*DTR) CB = COS(C(5)*DTR) CG = COS(C(6)*DTR) CASTAR = (CB*CG-CA)/(SB*SG) SASTAR = SQRT(1.0-CASTAR**2) OR(1,1) = C(1) OR(1,2) = C(2)*CG OR(1,3) = C(3)*CB OR(2,2) = C(2)*SG OR(2,3) = -C(3)*SB*CASTAR OR(3,3) = C(3)*SB*SASTAR C(7) = C(1)*C(2)*C(3)*SQRT(1.0-CA*CA-CB*CB-CG*CG+ 1 2.0*CA*CB*CG) C(8) = C(7)/(C(2)*C(3)*SA) C(9) = C(7)/(C(1)*C(3)*SB) C(10) = C(7)/(C(1)*C(2)*SG) RETURN * *** END FUNCTION VOLUME(C) * CALCULATE CELL-VOLUME FROM CELL-PARAMETERS * *** A, B, C, ALF, BET, GAM IN [C(1)--C(6)] * C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001. REAL C(10) DTR = ATAN(1.0)/45.0 CA = COS(C(4)*DTR) CB = COS(C(5)*DTR) CG = COS(C(6)*DTR) VOL = (1.-CA**2-CB**2-CG**2+2*CA*CB*CG) IF (VOL.LT.0.0) STOP 'CELL VOLUME IMAGINAIRE!!' VOLUME = C(1)*C(2)*C(3)*SQRT(VOL) RETURN END * *** SUBROUTINE REDUCED(TRS, G, TM) * CELL REDUCTION. SEE KRIVY GRUBER, ACTA CRYST (1976), A32, 297-298. REAL KSI, ETA, ZETA DIMENSION G(3,3), TM(3,3,8) LOGICAL TRS DATA LP, LG1 /6,7/ KSI = ANINT(2.*G(2,3)*1000.) ETA = ANINT(2.*G(1,3)*1000.) ZETA = ANINT(2.*G(1,2)*1000.) A = ANINT(G(1,1)*1000.) B = ANINT(G(2,2)*1000.) C = ANINT(G(3,3)*1000.) * REDUCTION STEP 1 10 L = 1 IF ((A.GT.B) .OR. ((A.EQ.B) .AND. (ABS(KSI).GT.ABS(ETA)))) THEN CALL REV(A, B) CALL REV(KSI, ETA) ETA = -ETA KSI = -KSI IF (TRS) CALL LEPAG04(L) END IF * REDUCTION STEP 2 L = 2 IF ((B.GT.C) .OR. ((B.EQ.C) .AND. (ABS(ETA).GT.ABS(ZETA)))) THEN CALL REV(B, C) CALL REV(ETA, ZETA) ETA = -ETA ZETA = -ZETA IF (TRS) CALL LEPAG04(L) GO TO 10 END IF * REDUCTION STEP 3 L = 3 IF (KSI*ETA*ZETA.GT.0.0) THEN TM(1,1,3) = SIGN(1.0,KSI) TM(2,2,3) = SIGN(1.0,ETA) TM(3,3,3) = SIGN(1.0,ZETA) KSI = ABS(KSI) ETA = ABS(ETA) ZETA = ABS(ZETA) IF (TRS) CALL LEPAG04(L) ELSE * REDUCTION STEP 4 L = 4 TM(1,1,4) = -(SIGN(1.0,KSI)) TM(2,2,4) = -(SIGN(1.0,ETA)) TM(3,3,4) = -(SIGN(1.0,ZETA)) IF (KSI .EQ. 0.0) TM(1,1,4)=TM(2,2,4)*TM(3,3,4) IF (ETA .EQ. 0.0) TM(2,2,4)=TM(1,1,4)*TM(3,3,4) IF (ZETA .EQ. 0.0) TM(3,3,4)=TM(1,1,4)*TM(2,2,4) KSI = -ABS(KSI) ETA = -ABS(ETA) ZETA = -ABS(ZETA) IF (TRS) CALL LEPAG04(L) END IF * REDUCTION STEP 5 L = 5 IF ((ABS(KSI).GT.B) .OR. ((KSI.EQ.B) .AND. (2*ETA.LT.ZETA)) .OR. 1 ((KSI.EQ.-B) .AND. (ZETA.LT.0.0))) THEN TM(3,2,5) = -(SIGN(1.0,KSI)) C = B + C - ABS(KSI) ETA = ETA - ZETA*SIGN(1.0,KSI) KSI = KSI - 2.*B*SIGN(1.0,KSI) IF (TRS) CALL LEPAG04(L) GO TO 10 END IF * REDUCTION STEP 6 L = 6 IF ((ABS(ETA).GT.A) .OR. ((ETA.EQ.A) .AND. (2*KSI.LT.ZETA)) .OR. 1 ((ETA.EQ.-A) .AND. (ZETA.LT.0.0))) THEN TM(3,1,6) = -SIGN(1.0,ETA) C = A + C - ABS(ETA) KSI = KSI - ZETA*SIGN(1.0,ETA) ETA = ETA - 2.*A*SIGN(1.0,ETA) IF (TRS) CALL LEPAG04(L) GO TO 10 END IF * REDUCTION STEP 7 L = 7 IF ((ABS(ZETA).GT.A) .OR. ((ZETA.EQ.A) .AND. (2*KSI.LT.ETA)) .OR. 1 ((ZETA.EQ.-A) .AND. (ETA.LT.0.0))) THEN TM(2,1,7) = -SIGN(1.0,ZETA) B = A + B - ABS(ZETA) KSI = KSI - ETA*SIGN(1.0,ZETA) ZETA = ZETA - 2.*A*SIGN(1.0,ZETA) IF (TRS) CALL LEPAG04(L) GO TO 10 END IF * REDUCTION STEP 8 L = 8 IF ((KSI+ETA+ZETA+A+B.LT.0.0) .OR. ((KSI+ETA+ZETA+A+B.EQ.0.0) 1 .AND. (2.*(A+ETA)+ZETA.GT.0.0))) THEN C = A + B + C + KSI + ETA + ZETA KSI = 2.*B + KSI + ZETA ETA = 2.*A + ETA + ZETA IF (TRS) CALL LEPAG04(L) GO TO 10 END IF * FINISHING OF THE REDUCTION PROCESS G(1,1) = A/1000. G(2,2) = B/1000. G(3,3) = C/1000. G(1,2) = ZETA/2000. G(1,3) = ETA/2000. G(2,3) = KSI/2000. G(3,2) = G(2,3) G(3,1) = G(1,3) G(2,1) = G(1,2) RETURN 99999 FORMAT (/1X, 6(F11.6)) END * *** SUBROUTINE TRMETR(G, TP) * TRANSFORM METRICAL MATRIX DIMENSION G(3,3), R(3,3), TP(3,3) DO 30 I=1,3 DO 20 J=1,3 R(I,J) = 0.0 DO 10 K=1,3 R(I,J) = R(I,J) + G(I,K)*TP(J,K) 10 CONTINUE 20 CONTINUE 30 CONTINUE DO 60 I=1,3 DO 50 J=1,3 G(I,J) = 0.0 DO 40 K=1,3 G(I,J) = G(I,J) + TP(I,K)*R(K,J) 40 CONTINUE 50 CONTINUE 60 CONTINUE RETURN END * *** * *** SUBROUTINE REV(A, B) * *** CHANGE VALUES OF A AND B C = A A = B B = C RETURN END * *** SUBROUTINE SMATVEC(A, B, C) DIMENSION A(3,3), B(3), C(3) DO 20 I=1,3 C(I) = 0.0 DO 10 J=1,3 C(I) = C(I) + A(I,J)*B(J) 10 CONTINUE 20 CONTINUE RETURN END * *** SUBROUTINE SMINV(A, B, DET) * *** INVERTS ASYMMETRIC 3X3 MATRIX DIMENSION A(3,3), B(3,3) B(1,1) = A(2,2)*A(3,3) - A(3,2)*A(2,3) B(2,1) = A(2,1)*A(3,3) - A(3,1)*A(2,3) B(3,1) = A(2,1)*A(3,2) - A(3,1)*A(2,2) DET = A(1,1)*B(1,1) - A(1,2)*B(2,1) + A(1,3)*B(3,1) IF (DET) 10, 40, 10 10 B(1,2) = A(1,2)*A(3,3) - A(3,2)*A(1,3) B(2,2) = A(1,1)*A(3,3) - A(3,1)*A(1,3) B(3,2) = A(1,1)*A(3,2) - A(3,1)*A(1,2) B(1,3) = A(1,2)*A(2,3) - A(2,2)*A(1,3) B(2,3) = A(1,1)*A(2,3) - A(2,1)*A(1,3) B(3,3) = A(1,1)*A(2,2) - A(2,1)*A(1,2) * *** MULTIPLY B(I,J) ELEMENTS BY -1**(I+J). THIS CAN BE ACCOMPLISHED * *** BY MULTIPLYING M BY -1 SONSECUTIVE FASHION M = -1 DO 30 I=1,3 DO 20 J=1,3 M = -M B(I,J) = FLOAT(M)*B(I,J)/DET 20 CONTINUE 30 CONTINUE 40 CONTINUE RETURN END * *** SUBROUTINE STRP(T, TR) DIMENSION T(3,3), TR(3,3) DO 20 I=1,3 DO 10 J=1,3 TR(J,I) = T(I,J) 10 CONTINUE 20 CONTINUE RETURN END