C          FILE GETSPEC
C               =======
C
C     V     V    AA     X     X
C     V     V   A  A     X   X
C      V   V   AAAAAA      X        -  VERSION
C       V V    A    A    X   X
C        V     A    A   X     X
C
C   THIS FILE CONTAINS THE FOLLOWING ROUTINES:
C
C  P GETSPEC        MAIN PROGRAM, INTERACTIVELY REQUESTS SPACE GROUP 
C                   SYMBOLS AND CALLS SUBROUTINES TO CALCULATE THE 
C                   SYMMETRY OPERATORS AND SPECIAL POSITIONS 
C  S SGHALL         CALCULATES SYMMETRY OPERATORS FROM HALL SYMBOL
C  S SYMD           DOUBLES NUMBER OF SYM.OPS. DUE TO CENTRE OF SYMMETRY
C  S SYMXYZ         PRINTS SYM.OPS. IN (X,Y,Z)-FORM
C  S GRMULT         CALCULATES THE POINT GROUP MULTIPLICATION TABLE
C  S SYMOP          DOES SYMMETRY TRANSFORMATIONS
C  S SYMULT         MULTIPLIES SYMMETRY OPERATORS
C  S WSCFS          CREATES AN OUTPUT FILE IN STANDARD CRYSTALLOGRAPHIC 
C                   FILE STRUCTURE (SCFS-84)
C  S INCREA         PRINTS OUT SYMMETRY TABLE
C  S CONXYZ         CONVERTS A SEITZ-MARIX TO (X,Y,Z)-FORM
C  F ICOMMA         COMPARES TWO (NXN)-MATRICES
C  F ICOMVE         COMPARES TWO (N)-VECTORS
C  F INTEGER        RETURNS INTEGER VALUE FOR REAL NUMBER, CORRECT ROUND-OFF
C  S MMINM          DIFFERENCE OF TWO MATRICES
C  S MXM            PRODUCT OF TWO MATRICES
C  S MXV            PRODUCT OF MATRIX * VECTOR
C  F SECOND         SYSTEM-DEPENDENT TIME CALLS
C  S VMINV          DIFFERENCE OF TWO VECTORS
C  S VPLUSV         SUM OF TWO VECTORS
C
C
c   GETSPEC calculates symmetry operators and special positions for any
c   given space group from the HALL space group symbol (which can be
c   obtained from the HERMANN-MAUGUIN symbol stored in the file SPGR.DAT).
c   The program is described by Altermatt and Brown in Acta Cryst. (1987)
c   A34, 125-130.
c
C   'GETSPEC' CALLS THE ROUTINES IN THE FILE 'GTSPLB'
C
C   'GETSPEC' OPENS THE EXISTING DATA FILE 'SPGR.DAT' IN DEFAULT DIRECTORY
C             CREATES FILE 'SCFS.DAT' AND, IF SPECIFIED, FILE 'DEBUG.DAT'
C             IN DEFAULT DIRECTORY
C
C   'SPGR.DAT' CONTAINS A CONCORDANCE BETWEEN HERMANN-MAUGUIN AND HALL
C             SPACE GROUP SYMBOLS
C
C
      PROGRAM GETSPEC
C
C   ***** INTERACTIVE VAX-VERSION *****
C
C   THIS PROGRAM WILL PROMPT FOR A HERMANN-MAUGUIN SYMBOL AS USED IN THE 
C   INORGANIC CRYSTAL STRUCTURE DATABASE, THE HALL SPACE GROUP SYMBOL AND
C   THE SPACE GROUP NUMBER. ONLY ONE OF THE TWO SYMBOLS IS NEEDED AND THE
C   SPACE GROUP NUMBER IS OPTIONAL. THE PROGRAM WILL THEN SEARCH THROUGH 
C   THE DATAFILE 'SPGR.DAT' TO GET THE EQUIVALENT OTHER SYMBOL AND SPACE 
C   GROUP NUMBER (IF NOT ALREADY GIVEN), CALCULATE THE SYMMETRY OPERATORS 
C   AND SPECIAL POSITIONS, SORT, PRINT AND STORE (ON FILE 'SCFS.DAT') ALL 
C   THE DATA.
C
C   THE FOLLOWING ROUTINES ARE CALLED:
C
C       GETSPEC:  SECOND, SGHALL, GRMULT, WSCFS, CONXYZ
C       SPELIB:   SPOST, SPESOR, SPMULT, SPSYM
C
C
C   THE FINAL ORDERING OF THE SPECIAL POSITIONS IS THAT DESCRIBED BY THE
C   AUTHOR IN ACTA CRYST (1985)
C
C
C    NOTES ON THE NAMES OF ARRAYS USED IN MCMASTER 
C         CRYSTALLOGRAHIC PROGRAMS
C
C    NOTE:  Matrices are given as M(row,column)
C           default integer names are used
C           implicit character*8 (g)
C           implicit character*80 (h)
C    FILES
C    -----
C    nin         input file number
C    nout        output file number
C    ndebug      debug output file number(set to 0)
C    nread       input data file number
C    nwrite      output data file number
C    nspgr       input space group file
C
C    SYM
C    ---
C    nsym        number of symmetry operators stored
C    msym        dimension of symmetry arrays (=48)
C    s(3,3,48)   rotation matrix
C    t(3,48)     translation matrix
C    nt          multiplicity of lattice
C    tu(3,4)     translations due to lattice centrings (including (0,0,0))
C
C    GSYM
C    ----
C    glat        lattice type
C    gcent       A/C acentric/centric
C    hmsym       Hermann-Mauguin space group symbol
C    hall        Hall space group symbol
C    gsysp(2,30) Wyckoff symbol, site symmetry
C
C    SYMA
C    ----
C    mult(48,48) symmetry multiplication table
C    it(3,48)    symmetry translations in integer form (*12)
C    nsp         number of special positions stored
C    msp         dimensions of special position arrays (=30)
C    isptab(48,30) equivalent symmetry operators for a given special
C                  position
C    multsp(30)  multiplicity of special postions
C    sp(3,3,30)  rotation matirix for special position operator
C    tp(3,30)    translation vector for secial position operator
C
C    REFERENCE:  ACTA CRYST.
C
C    WRITTEN IN JUNE 1985 BY DANIEL ALTERMATT, MCMASTER UNIVERSITY, HAMILTON
C
      implicit character*8 (g)
      implicit character*80 (h)
C
C     system common blocks
C
      common /files/  nin,nout,ndebug,nread,nwrite,nspgp
      common /sym/    nsym,msym,s(3,3,48),t(3,48),nlt,tu(3,4)
      common /gsym/   glat,gcent,hmsym,hall,gsysp(2,30)
      common /syma/   mult(48,48),it(3,48),nsp,msp,isptab(48,30),
     1                multsp(30),sp(3,3,30),tp(3,30)
C
C     START TIMER
C
      TIME = SECOND(1)
C
C     GREET USER AND SET DEFAULT VALUES IN COMMON BLOCKS
C
      NIN = 5
      NOUT = 6
      WRITE(NOUT,2000)
 2000 FORMAT('1',////,10x,' Welcome to program GETSPEC !',//,
     1  10x,' We will prompt you for a Hermann-Mauguin and a Hall',/,
     2  10x,' Space Group Symbol and then derive all symmetry',/,
     3  10x,' operators and special positions for the given space',/,
     4  10x,' group. ',//,
     5  10x,' You may enter either one or both symbols. If given,',/,
     6  10x,' the Hall-Symbol will be used for calculations.',///)
C-----------------
C     IF YOU WOULD LIKE A DEBUG OUTPUT, YOU MAY SET 'NDEBUG = 8' AND 
C     REMOVE THE 'C' FROM THE FOLLOWING LINE. THIS WILL WRITE DEBUG 
C     STATEMENTS TO 'DEBUG.DAT'.
C     ***** FOR CUBIC GROUPS THE SIZE OF 'DEBUG.DAT' MAY GET ENORMOUS.
C
      NDEBUG = 0
C     OPEN (8,FILE='DEBUG.DAT',STATUS='NEW')
C-----------------
      NREAD = NIN
      NWRITE = 9
      OPEN (9,FILE='SCFS.DAT',STATUS='NEW',CARRIAGECONTROL='LIST')
      NSPGR = 10
      OPEN (10,FILE='SPGR.DAT',STATUS='UNKNOWN')
C
C     STARTING POINT FOR RE-RUNS, GET CURRENT RUNTIME
C
   10 TIME = SECOND(3)
C
      NSYM = 0
      MSYM = 48
      NT = 1
      TU(1,1) = 0.0
      TU(2,1) = 0.0
      TU(3,1) = 0.0
C
      GLAT = ' '
      GCENT = ' '
      HMSYM = ' '
      HALL = ' '
C
      NSP = 0
      MSP = 30
C
C     CHECK IF 'SPGR.DAT' EXISTS IN CURRENT DIRECTORY
C
      REWIND(NSPGR)
      READ(NSPGR,1000,END=900) HLINE
 1000 FORMAT(A80)
      REWIND(NSPGR)
   15 WRITE(NOUT,2010)
 2010 FORMAT(/,'$ Enter Herman-Mauguin Space Group Symbol (or <RTN>): ')
      READ(NIN,1000,ERR=20,END=20) HMSYM
      IF (HMSYM.EQ.'<RTN>'.OR.HMSYM.EQ.'<rtn>') GOTO 20
      GOTO 30
   20 HMSYM = ' '
   30 WRITE(NOUT,2020)
      HMS = HMSYM
 2020 FORMAT(/,'$ Enter Hall Space Group Symbol (or <RTN>): ')
      READ(NIN,1000,ERR=40,END=40) HALL
      IF (HALL.EQ.'<RTN>'.OR.HALL.EQ.'<rtn>') GOTO 40
      GOTO 50
   40 HALL = ' '
   50 IF (HALL.EQ.' '.AND.HMSYM.EQ.' ') THEN
         WRITE(NOUT,2030)
 2030    FORMAT(//'  Come on Buddy, enter at least one legal symbol',
     1      ' !!!',///)
         GOTO 15
         ENDIF
C
C     CONVERT INPUT TO CAPITAL LETTERS
C
      IF (HALL.NE.' ') THEN
         HMS = ' '
         DO 45 I=1,15
            IF (ICHAR(HALL(I:I)).LT.ICHAR('a').OR.ICHAR(HALL(I:I))
     1         .GT.ICHAR('z')) GOTO 45
            INP = ICHAR(HALL(I:I))-ICHAR('a')+ICHAR('A')
            HALL(I:I) = CHAR(INP)
   45       CONTINUE
      ELSE
         DO 55 I=1,24
            IF (ICHAR(HMSYM(I:I)).LT.ICHAR('a').OR.ICHAR(HMSYM(I:I))
     1         .GT.ICHAR('z')) GOTO 55
            INP = ICHAR(HMSYM(I:I))-ICHAR('a')+ICHAR('A')
            HMSYM(I:I) = CHAR(INP)
   55       CONTINUE
         ENDIF
      WRITE(NOUT,2040)
 2040 FORMAT(/,'  Enter Space Group Number (as in International',
     1   ' Tables',/,'$ for Crystallography) or 0 (zero): ')
      READ(NIN,1010,ERR=60,END=60) NGROUP
 1010 FORMAT(I5)
      IF (NGROUP.LT.1.OR.NGROUP.GT.230) GOTO 60
      GOTO 70
   60 NGROUP = 0
C
C     MAKE SURE THAT THE SYMBOLS ARE LEFT JUSTIFIED
C
   70 IF (HMS .NE. ' ') THEN
         DO 75 I=1,24
   75       IF (HMSYM(I:I).NE.' ') GOTO 80
   80    II = 24-I+1
         IF (II.EQ.24) GOTO 100
         HMSYM(1:II) = HMSYM(I:24)
         HMSYM(II+1:24) = ' '
      ELSE
         DO 85 I=1,15
   85       IF (HALL(I:I).NE.' ') GOTO 90
   90    II = 15-I+1
         IF (II.EQ.15) GOTO 100
         HALL(1:II) = HALL(I:15)
         HALL(II+1:15) = ' '
         ENDIF
C
C     READ 'HALL' AND/OR 'NGROUP' FROM 'NSPGR'
C
  100 READ(NSPGR,1000,END=910) HLINE
      IF (HALL.EQ.' ') THEN
         IF (HMSYM(1:24).NE.HLINE(6:29)) GOTO 100
         HALL(1:15) = HLINE(30:44)
      ELSE
         IF (HALL(1:15).NE.HLINE(30:44)) GOTO 100
         HMSYM(1:24) = HLINE(6:29)
         ENDIF
      READ(HLINE(45:49),'(BZ,I5)') NGRP
      IF (NGRP.EQ.0) GOTO 110
      IF (NGROUP.NE.0.AND.NGROUP.NE.NGRP) THEN
         WRITE(NOUT,2050) NGROUP,NGRP
 2050    FORMAT(//,' ***** ERROR: Space Group Number given is:',i5,
     1   //,13x,' Space Group Number found is:',i5,
     2   //,13x,' Second number taken !!',//)
         ENDIF
      NGROUP = NGRP
C
C     CALCULATE THE SYMMETRY OPERATORS
C
  110 WRITE(NOUT,2060)
 2060 FORMAT(//,'  ----- Calculating the Symmetry Operators ...')
      CALL SGHALL
      IER = 0
      CALL GRMULT(IER)
      IF (IER.NE.0) GOTO 930
C
C     CALCULATE AND SORT THE SPECIAL POSITIONS
C
      WRITE(NOUT,2070)
 2070 FORMAT(//,'  ----- Calculating the Special Positions ...')
      IER = 0
      CALL SPOST(IER,NDEBUG)
      IF (IER.NE.0) GOTO 920
      WRITE(NOUT,2080)
 2080 FORMAT(//,'  ----- Sorting the Special Positions ...')
      CALL SPESOR
      CALL SPMULT
      CALL SPSYM
C
C     OK, ALL DONE. PRINT AND STORE RESULTS
C
      CALL WSCFS
      WRITE(NOUT,2100) NGROUP,HMSYM(1:15),HALL(1:15)
 2100 FORMAT(20(/),'  Space Group Number             ',i5,/,
     1             '  Hermann-Mauguin Symbol         ',a15,/,
     2             '  Hall Symbol                    ',a15,///,
     3  '$ Hit <RETURN> to continue: ')
      READ(NIN,1020,ERR=120,END=120) GDUM
 1020 FORMAT(A1)
  120 WRITE(NOUT,2110)
 2110 FORMAT(///,'  Symmetry Operators:',/)
      LINC = 0
      DO 130 I=1,NSYM
         LINC = LINC+1
         CALL CONXYZ(S(1,1,I),T(1,I),HBUF)
         WRITE(NOUT,2120) I,HBUF
 2120    FORMAT(1X,I5,5X,A30)
         IF (LINC.EQ.20.OR.I.EQ.NSYM) THEN
            WRITE(NOUT,2130)
 2130       FORMAT(//,'$ Hit <RETURN> to continue: ')
            READ(NIN,1020,ERR=140,END=140) GDUM
  140       IF (I.NE.NSYM) WRITE(NOUT,2110)
            LINC = 0
            ENDIF
  130    CONTINUE
      WRITE(NOUT,2140)
 2140 FORMAT(///,'  Listing of Special Positions:',//,
     1   '  Nr.   Coordinates          Multiplicity    Site Symmetry',/)
      LINC = 0
      DO 150 I=1,NSP
         LINC = LINC+1
         CALL CONXYZ(SP(1,1,I),TP(1,I),HBUF)
         WRITE(NOUT,2150) I,HBUF,MULTSP(I),GSYSP(2,I)
 2150    FORMAT(1X,I4,3X,A21,5X,I3,11X,A8)
         IF (LINC.EQ.18.OR.I.EQ.NSP) THEN
            WRITE(NOUT,2130)
            READ(NIN,1020,ERR=160,END=160) GDUM
  160       IF (I.NE.NSP) WRITE(NOUT,2140)
            LINC = 0
            ENDIF
  150    CONTINUE
      TIME=SECOND(3)-TIME
      WRITE(NOUT,2155) TIME
 2155 FORMAT(//,'  Elapsed CPU-Time: ',F7.2,' Seconds')
  170 WRITE(NOUT,2160)
 2160 FORMAT(/////,'$ Another Space Group to be done (Y/N): ')
      READ(NIN,1020,ERR=180,END=180) GYN
      IF (GYN.EQ.'Y'.OR.GYN.EQ.'y') GOTO 10
      IF (GYN.EQ.'N'.OR.GYN.EQ.'n') GOTO 999
  180 WRITE(NOUT,2170)
 2170 FORMAT(//,'  ****** INPUT ERROR ******* TRY AGAIN ******',//,
     1          '  only YES (yes,Y,y) or NO (no,N,n) are valid')
      GOTO 170
  900 WRITE(NOUT,2200) NSPGR
 2200 FORMAT(///,'  ****** ERROR: File',i3,' empty ******',//,
     1   '  ''SPGR.DAT'' must be in your current Directory !!',////)
      GOTO 999
  910 IF (HALL.NE.' ') THEN
         IF(NGROUP.LE.1.OR.NGROUP.GT.230) NGROUP = 0
         GOTO 110
         ENDIF
      WRITE(NOUT,2210) NSPGR
 2210 FORMAT(///,'  ****** ERROR: End-of-File in unit',i3,' ******')
      IF (HMSYM.NE.' ') WRITE(NOUT,2220) 'Hermann-Mauguin',HMSYM
      IF (HALL.NE.' ')  WRITE(NOUT,2220) '           Hall',HALL
 2220 FORMAT(//,2X,A15,' Symbol ',A15,' not found in ''SPGR.DAT'' ',
     1   ////)
      GOTO 170
  920 WRITE(NOUT,2230) IER
 2230 FORMAT(///,'  ****** ERROR: Malfunction of Routine SPOST ******',
     1   /,'         Error number',i3,//,'         Now you''re really',
     2   ' screwed !!',//,'         Try to DEBUG by yourself or call',
     3   ' the author...',////)
      GOTO 999
  930 WRITE(NOUT,2240)
 2240 FORMAT(///,'  ****** ERROR: Your Space Group Symbol is probably',
     1   ' incomplete',////)
      GOTO 170
  999 CLOSE(NSPGR)
      CLOSE(NWRITE)
      WRITE(NOUT,2300)
 2300 FORMAT(/,'  Your current Directory now contains a file SCFS.DAT',
     1   /,'  where above information is stored in Standard Crystal-',
     2   /,'  lographic File Structure (SCFS).',////)
      STOP
      END
C
C
C
C
      SUBROUTINE SGHALL
*
*
* WRITTEN BY DAVID R. MOSSCROP (7901822)
* MAY-JUNE ; 1982.
*
* FROM AN ARTICLE AND PROGRAM: NEW SPACE GROUP NAMES.
*      BY HALL 1982  REF:ACTA CRYST .A36, 517-523.
*
* CALLS SYMD, SYMXYZ
*
* THIS PROCEDURE USES THE HALL SPACE GROUP NAME TO GENERATE 
* THE CORPSONDING MATRIX TRANSFORMATIONS.
C
C   MODIFIED 84.2.14 BY I D BROWN TO ALLOW ORIGIN SHIFT
C   UPDATED BY D. ALTERMATT
*
      IMPLICIT CHARACTER*8 (G)
      IMPLICIT CHARACTER*80 (H)
C
      INTEGER OLD
      INTEGER ROT(12,20)
      INTEGER SMAT(16,50)
      INTEGER SVEC(3)
      DIMENSION ISHIFT(3),GCHR(30)
      INTEGER TAB(3,9)
      INTEGER VEC(3,8)
      COMMON/FILES/NIN,NOUT,NDEBUG,NREAD,NWRITE,NSPGP
      COMMON /SYM/ NSYM,MSYM,S(3,3,48),T(3,48),NLT,TU(3,4)
      COMMON /GSYM/ GLAT,GCENT,HMSYM,HALL
*
* VARIABLE DICTIONARY: 
*
* GCENT IS CENTROSYMMETRIC FLAG (N OR C)
* GLAT IS LATTICE FLAG (P,R,A,B,C,I,F). 
* IAXS IS CURRENT AXIS POINTER TO TAB.
* ISGN IS MATRIX SIGN FLAG.
* IROT IS CURRENT ORDER POINTER TO TAB. 
* JAXS IS PREVIOUS AXIS POINTER TO TAB. 
* JROT IS PREVIOUS ORDER POINTER TO TAB.
* NIN IS INPUT DEVICE NUMBER. 
* NOUT IS OUTPUT DEVICE NUMBER.
* NSYM IS NUMBER OF EQUIVALENT POSITIONS.
* NGEN IS NUMBER OF GENERATED SEITZ MATRICES.
* NROT IS CURRENT ROTATION ORDER (1,2,3,4,6).
* NEW IS POSITION OF MATRIX PRODUCT.
* OLD IS MATRIX COUNT BEFORE INNER LOOP.
* ROT(12,20) IS TABLE OF ROTATION MATRICES.
* SMAT(16,50) IS SEITZ MATRIX ARRAY.
* SVEC(3) IS TEMPORARY T-VECTOR ARRAY.
* ISHIFT IS THE ORIGIN SHIFT
* TAB(3,9) POINTS TO ROT(AXIS,ORDER).
* VEC(3,8) IS THE T-VETORS FOR A,B,C,N,U,V,W,D.
*
******************************************************************
* LOADING INITIAL DATA
*
      DATA ROT/
     1 1,0,0,0, 0,1,0,0, 0,0,1,0,
     2 1,0,0,0, 0,-1,0,0, 0,0,-1,0,
     3 -1,0,0,0, 0,1,0,0, 0,0,-1,0,
     4 -1,0,0,0, 0,-1,0,0, 0,0,1,0,
     5 1,0,0,0, 0,0,1,0, 0,-1,-1,0,
     6 -1,0,-1,0, 0,1,0,0, 1,0,0,0,
     7 0,1,0,0, -1,-1,0,0, 0,0,1,0,
     8 1,0,0,0, 0,0,1,0, 0,-1,0,0,
     9 0,0,-1,0, 0,1,0,0, 1,0,0,0,
     1 0,1,0,0, -1,0,0,0, 0,0,1,0,
     2 1,0,0,0, 0,1,1,0, 0,-1,0,0,
     3 0,0,-1,0, 0,1,0,0, 1,0,1,0,
     4 1,1,0,0, -1,0,0,0, 0,0,1,0,
     5 0,0,1,0, 1,0,0,0, 0,1,0,0,
     6 -1,0,0,0, 0,0,-1,0, 0,-1,0,0,
     7 0,0,-1,0, 0,-1,0,0, -1,0,0,0,
     8 0,-1,0,0, -1,0,0,0, 0,0,-1,0,
     9 -1,0,0,0, 0,0,1,0, 0,1,0,0,
     1 0,0,1,0, 0,-1,0,0, 1,0,0,0,  0,1,0,0, 1,0,0,0, 0,0,-1,0/
*
      DATA GCHR/'1','2','3','4','5','6','P','R','A','B','C','I','F',
     1'N','U','V','W','D',' ','-','X','Y','Z','*','''','"','(','0','H',
     2'H'/
*
      DATA TAB/1,1,1,2,3,4,5,6,7,8,9,10,0,0,0,11,12,13,                 
     1  14,14,14,15,16,17,18,19,20/
*
      DATA VEC/6,0,0, 0,6,0, 0,0,6, 6,6,6,                              
     1  3,0,0, 0,3,0, 0,0,3, 3,3,3/
*
* VARIABLE INITIALIZATION.
*
      JCENT=0
      GCENT=GCHR(14) 
      GLAT=' '
      NGEN=1
      NSYM=1
      ISGN=12
      NLT=1
*
      NROT=0
      LLTCODE=0
      IROT=0
      JROT=0
      IAXS=0
      JAXS=0
*
******************************************************************
* THE PROGRAM: SGHALL
*
* ARRAY INITIALIZATION.
*
*
* ZERO VECTOR ACCUMULATOR.
*
      DO 1 I=1,3
      SVEC(I)=0
      TU(I,NLT)=0.0
    1 CONTINUE
*
* SET THE (4,4) ELEMENT TO 1.0.
*
      DO 2 I=1,50
      SMAT(16,I)=12 
      SMAT(4,I)=0
      SMAT(8,I)=0
      SMAT(12,I)=0
    2 CONTINUE
*
* SET ORIGIN SHIFT TO ZERO
*
      DO 30 I=1,3
   30   ISHIFT(I)=0 
*
* SET IDENTITY ROTATIONS.
*
      DO 3 I=1,12
      SMAT(I,1)=ROT(I,1)*12
    3 CONTINUE
*
* SET IDENTITY TRANSLATIONS.
*
      DO 4 I=13,16
      SMAT(I,1)=ROT(I-10,1)*12
    4 CONTINUE
*
* CHECKING ELEMENT BY ELEMENT AND SET VARIABLES AS NEEDED.
*
      DO 66 N=1,15
      DO 6 M=1,29
      IF (HALL(N:N).EQ.GCHR(M)) GO TO 606
    6 CONTINUE
*
* ERROR CONDITION CHARACTER NOT IDENTIFIED.
*
      WRITE(NOUT,1670) HALL(N:N),N
 1670 FORMAT(' ++ERROR++SGHALL++1670++ ILLEGAL CHARACTER: ',A1,
     1       ' IN COLUMN ',I1)
*
* SKIP INACTIVE BLANKS.
*
  606 IF ((M.EQ.19).AND.(NROT.EQ.0)) GO TO 66
C
C  BLANK INITIATES CONSTRUCTION OF SYMMETRY GENERATOR
C
      IF ( M.EQ.19 ) GO TO 1011
C
C PARENTHESIS INITIATES READING OF ORIGIN SHIFT
C
      IF(M.EQ.27) GO TO 40
*
*
* SET GCENT AND GLAT, DEPENDENT ON FIRST ELEMENT(S).
*
      IF ( LLTCODE .NE. 0) GO TO 1000
*
* FIRST NEGATIVE SIGN INDICATES CENTRE. 
*
      IF (M .NE. 20) GO TO 1001
      JCENT=1
      GCENT=GCHR(11)
      GO TO 66
*
* ALLOWED CHARACTERS: P,R,A,B,C,I,F TO SET LTCODE.
*
 1001 IF ((M .GE. 7).AND.(M .LE.13)) GO TO 2000
      WRITE(NOUT,1600) GCHR(M)
 1600 FORMAT(' ++ERROR++SGHALL++1600++ UNRECOGNISED LATTICE TYPE ',
     1 A1)
      GO TO 150
 2000 CONTINUE
      LLTCODE=M-6
      GLAT=GCHR(M)
*
* SPACE GROUPS WITH NAMES 'R' TYPE ARE ASSIGNED
* GLAT 'H' FOR A HEXAGONAL SETTING. THIS IS A
* LOCAL CONVENTION. 
*
      IF ( M .EQ. 8 ) GLAT=GCHR(30)
*
* ADD CENTERING TRANSLATIONS TO =TU=
*
      IF(GLAT.EQ.'P') GOTO 660
      IF(GLAT.EQ.'I') THEN
        NLT=NLT+1
        DO 60 I=1,3
   60   TU(I,NLT)=0.5
        GOTO 660
        ENDIF
      IF(GLAT.EQ.'A'.OR.GLAT.EQ.'F') THEN
        NLT=NLT+1
        TU(1,NLT)=0.0
        TU(2,NLT)=0.5
        TU(3,NLT)=0.5
        IF(GLAT.EQ.'A') GOTO 660
        ENDIF
      IF(GLAT.EQ.'B'.OR.GLAT.EQ.'F') THEN
        NLT=NLT+1
        TU(1,NLT)=0.5
        TU(2,NLT)=0.0
        TU(3,NLT)=0.5
        IF(GLAT.EQ.'B') GOTO 660
        ENDIF
      IF(GLAT.EQ.'C'.OR.GLAT.EQ.'F') THEN
        NLT=NLT+1
        TU(1,NLT)=0.5
        TU(2,NLT)=0.5
        TU(3,NLT)=0.0
        GOTO 660
        ENDIF
      IF(GLAT.EQ.'H') THEN
        NLT=NLT+1
        TU(1,NLT)=0.3333333
        TU(2,NLT)=0.6666667
        TU(3,NLT)=0.6666667
        NLT=NLT+1
        TU(1,NLT)=0.6666667
        TU(2,NLT)=0.3333333
        TU(3,NLT)=0.3333333
        ENDIF
  660 IF(NDEBUG.NE.0) WRITE(NDEBUG,2020) ((TU(I1,I2),I1=1,3),I2=1,NLT)
 2020 FORMAT(/,' ++DEBUG++SGHALL++2020++  TU(3,NLT)',4(/,26X,3F5.2))
      GOTO 66
*
* IF CHARACTER IS A NEGATIVE SIGN, SET ISGN TO NEGATIVE,
* OTHERWISE POSITIVE. THE LATER NEGATIVE SIGNS INDICATE
* INVERSIONS.
*
 1000 IF (M.NE.20) GO TO 999
      ISGN=-12
      GO TO 66
*
* ROTATION MUST FOLLOW LATTICE TYPE.
*
*
* IF ROTATION AXIS ALREADY SET GO TO 1003.
*
  999 IF (NROT .NE. 0) GO TO 1003
      IF (M .LE.6) GO TO 2011 
      WRITE(NOUT,2010) GCHR(M)
 2010 FORMAT(' ++ERROR++SGHALL++2010++ ILLEGAL ROTATION CHARACTER '
     1 ,A1)
      GO TO 150
 2011 CONTINUE
*
* SET ROTATION AXIS IN NROT.
*
      IF ((M .EQ. 1) .AND. (ISGN .LT.0)) NSYM=NSYM*2
      NROT=M
      IROT=M
      IF ((M.NE.1).OR.(ISGN.LT.0)) NGEN=NGEN+1
      IF(NGEN.LE.MSYM) GO TO 1005
      WRITE(NOUT,1501)
 1501 FORMAT(' ++ERROR++SGHALL++1501++ NGEN GREATER THAN MSYM.')
      NSYM=0
      RETURN
*
*********** SELECT AXIS EXPLICILY **************
*
* IF CHARACTER DOES NOT SET AXIS GO TO 1005.
*
 1003 IF (M .LE. 20) GO TO 1009
      IAXS=M-20
      GO TO 1004
*
* SET AXIS IMPLICITLY.
*
*
*  IF DEFAULT AXIS NOT REQUIRED GO TO 1004.
*
 1005 CONTINUE
*
*  FIRST AXIS ASSUMED Z.
*
      IF ((NGEN .NE.2).AND.(IROT .NE.1)) GO TO 1006
      IAXS=3
      GO TO 1004
*
* SECOND AXIS ASSUMED X IF NROT=2 AND PREVIOUS AXIS WAS 2 OR 4.
*
 1006 IF ((NROT .NE.2) .OR. (JROT .NE.2)) GO TO 1007
      IAXS=1
      GO TO 1004
*
* AXIS AFTER 3,6 ASSUMED AS X-Y.
*
 1007 IF (( NROT .NE.2) .OR.(JROT .NE.3))  GO TO 1008
      IAXS=5
      GO TO 1004
 1008 IF (NROT .EQ.3) GO TO 2500
      WRITE(NOUT,1639)
 1639 FORMAT(' ++ERROR++SGHALL++1639++ UNABLE TO ASSIGN IMPLICIT ',
     1 'AXIS.')
      GO TO 150
 2500 IAXS=4
*
*
* FOR NON-PRINCIPAL AXES.
*
 1004 IF (IAXS .LE.3) GO TO 66
      IROT=IAXS+3
      IAXS=JAXS
      IF((IAXS.EQ.0).AND.(IROT.EQ.7))IAXS=1
      GO TO 66
*
********** SPECIFY TRANSLATION ***********
*
*
* ONLY FOR X,Y,Z DIRECTIONS.
*
 1009 IF(M .GT. 6) GO TO 1010 
      IF (IROT .GT.M) GO TO 2510
      WRITE(NOUT,1660) GCHR(M)
 1660 FORMAT(' ++ERROR++SGHALL++1660++ ILLEGAL SCREW AXIS SYMBOL ',
     1 A1)
      GO TO 150
 2510 CONTINUE
*
* CALCULATE TRANSLATIONS IN 12 THS.
*
      SVEC(IAXS)=SVEC(IAXS)+M*12/NROT
*
* TEST FOR A,B,C,N,U,V,W,D.
*
 1010 IF(((M.LE.8).OR.(M.GE.12)).AND.((M.LE.13).OR.(M.GE.19)))GOTO1011
      IF (M .GE. 12) GO TO 1111
      I=M-8
      GO TO 1112
 1111 I=M-10
 1112 DO 7 J=1,3
      SVEC(J)=SVEC(J)+VEC(J,I)
    7 CONTINUE
      GO TO 66
*
* CONSTRUCT GENERATOR WHEN BLANK IS REACHED.
*
 1011 IF (M .NE.19) GO TO 66
*
* POINT TO ROTATION MATIX.
*
      K=TAB(IAXS,IROT)
      DO 8 I=1,12
      SMAT(I,NGEN)=ROT(I,K)*ISGN
    8 CONTINUE
      DO 9 I=13,15
*
* DEPOSIT TRANSLATON BASE 12. 
*
      SMAT(I,NGEN)=MOD(SVEC(I-12)+120,12)
    9 CONTINUE
*
* CALCULATE THE NUMBER OF EQUIVALENT POSITIONS.
*
      NSYM=NSYM*NROT
      IF (NROT .GT. 3) NROT=NROT/2
*
* RESET ORDER FLAGS AND AXIS FLAGS.
*
      JROT=NROT
      NROT=0
      IROT=0
      JAXS=IAXS
      IAXS=0
      ISGN=12
*
* ZERO VECTOR ACCUMULATOR.
*
      DO 10 I=1,3
      SVEC(I)=0
   10 CONTINUE
*
      IF(HALL(N:N+1).EQ.'  ') GOTO 666
      GO TO 66
C
C   READ ORIGIN SHIFT
C
   40 IAX=0
      NN=N
   41 ISIGN=1
      IAX=IAX+1
      IF(IAX.GT.3) GO TO 666
   42 NN=NN+1
      DO 45 M=1,29
   45 IF(HALL(NN:NN).EQ.GCHR(M)) GO TO 47
      WRITE(NOUT,1670) HALL(NN:NN),NN
      GO TO 150
   47 IF(M.EQ.20) THEN
        ISIGN=-1
        GO TO 42
        ENDIF
      IF(M.EQ.28) THEN
        ISHIFT(IAX)=0
        GO TO 41
        ENDIF
      IF(M.LE.6) THEN
        ISHIFT(IAX)=ISIGN*M
        GO TO 41
        ENDIF
      IF(M.EQ.29) GO TO 666
      WRITE(NOUT,200) HALL(NN:NN),NN
      NSYM=0
      RETURN
   66 CONTINUE
  666 CONTINUE
      IF(NDEBUG.NE.0) THEN
        WRITE(NDEBUG,1666) GLAT,NROT,ISHIFT
        DO 667 I=1,NGEN
          WRITE(NDEBUG,1667) (SMAT(J,I),J=1,16)
  667     CONTINUE
 1666   FORMAT(' ++DEBUG++SGHALL++1666++ LATCODE=',A1,' NROT=',I3,
     1   ' ISHIFT=',3I4)
 1667   FORMAT(10X,16I4)
        ENDIF
*
* END OF INPUT DATA (HALL SPACE GROUP NAME) EVALUATION LOOPS.
*
* CHECK FOR ERROR CONDITION.
*
      IF ((NROT .LE.0).AND.(LLTCODE .NE.0)) GO TO 151
  150 CONTINUE
*
* ERROR CONDITION.
*
      WRITE(NOUT,200) HALL(N:N),N,NROT,LLTCODE,GLAT,GCENT
  200 FORMAT (' ++DEBUG++SGHALL++200++  ILLEGAL CONSTRUCTION AT',
     1       ' CHARACTER ',A1,' IN COL.',I3,/,25X,'NROT =',I3,
     1       ', LLTCODE =',I3,', GLAT = ',A1,', GCENT = ',A1,/)
      NSYM=0
      RETURN
  151 CONTINUE
*
*
*GENERATE MATRICES BY PROGRESSIVE BINARY PRODUCTS.
*
*
*
* SKIP GENERATOR IF P1 OR -P1.
*
      IF (NGEN .LE.1) GO TO 117
      M=2 
  723 IF(M.LE.NGEN) GO TO 273 
      GO TO 105
*
* SAVE CURRENT MATRIX COUNT.
*
  273 OLD=NGEN
      N=M 
  724 IF(N.LE.NGEN) GO TO 274 
      GO TO 11
*
* POINT TO GENERATED MATRIX IN SMAT.
*
  274 NEW=NGEN+1
*
      DO 13 I=1,3
      DO 131 J=1,13,4
  131 SMAT(I+J-1,NEW)=((SMAT(I,M)*SMAT(J,N))+(SMAT(I+4,M)*SMAT(J+1,N))+ 
     1   (SMAT(I+8,M)*SMAT(J+2,N))+(SMAT(I+12,M)*SMAT(J+3,N)))/12
      SMAT(I+12,NEW)=MOD(SMAT(I+12,NEW)+120,12)
   13 CONTINUE
*
* IS MATRIX UNIQUE? 
*
      LFLAG=1
      DO 14 L=1,NGEN
      DO 103 I=1,12 
  103 IF (SMAT(I,L).NE.SMAT(I,NEW)) GO TO 1674
      IF (LLTCODE .NE. 1) GO TO 251
      DO 15 II=13,16
      IF (SMAT(II,L) .EQ. SMAT(II,NEW)) GO TO 15
*
* ERROR CONDITION FOUND.
*
      WRITE (NOUT,300)
  300 FORMAT('++SGHALL++ERROR: MATRICES RELATED BY PURE TRANSLATION.')
      NSYM=0
      RETURN
   15 CONTINUE
*
      GO TO 251
*
 1674 DO 16 J=1,12
   16 IF (SMAT(J,L) .NE. SMAT(J,NEW)) GO TO 20
*
* ERROR CONDITION NOT AVOIDED ( IE NOT SKIPPED OVER).
*
      WRITE(NOUT,400)
  400 FORMAT('++SGHALL++ERROR: SOME MATRICES RELATED BY INVERSION.')
      NSYM=0
      RETURN
*
   20 CONTINUE
      LFLAG=LFLAG+1 
   14 CONTINUE
  251 IF (LFLAG .GT. NGEN) NGEN=NEW
      N=N+1
      GO TO 724
   11 IF ((NGEN.EQ.OLD).AND.(NGEN.GE. NSYM)) GO TO 105
      M=M+1
      GO TO 723
  105 CONTINUE
*
*
* SORT ON ZERO PATTERN.
*
      DO 17 N=2,NGEN
      DO 18 L=N,NGEN
      DO 181 K=1,12 
*
* EXIST ON ZERO MISMATCH.
*
  181 IF((SMAT(K,N-1).EQ.0).AND.(SMAT(K,L).NE.0))GO TO 18
      GO TO 1171
   18 CONTINUE
      GO TO 17
*
*
* EXCHANGE SORTED ELEMENTS.
*
 1171 DO 19 K=1,16
      I=SMAT(K,L)
      SMAT(K,L)=SMAT(K,N)
      SMAT(K,N)=I
   19 CONTINUE
*
   17 CONTINUE
  117 CONTINUE
*
* ERROR CHECK OF NGEN RELATIVE TO NSYM. 
*
      IF (NGEN .LE. NSYM) GO TO 1013
      WRITE(NOUT,500) NGEN,NSYM
  500  FORMAT('++SGHALL++ERROR: ',I5,' MATRICES GENERATED,',I5,
     1       ' EXPECTED')
      NSYM=0
*
* THE FOLLOWING LOOPS ENTERS THE VALUES OF SMAT(16,48),
* WHICH IS THE ARRAY USED IN THIS ROUTINE TO STORE THE
* ROTATION AND TRANSLATION MATRICES, INTO TWO COMPARABLE
* ARRAYS S(3,3,48) AND T(3,48) WHICH ARE USED IN OTHER
* ROUTIES EXTERNAL TO SGHALL. 
*
 1013 DO 7775 M=1,48
      DO 7775 J=1,3 
      DO 7775 I=1,3 
      K=4*(J-1)+I
*
* REAL DIVISION BY ZERO IS NEEDED TO CONVERT THE 12 THS
* USED IN SGHALL INTO ROTATIONS AND TRANSLATIONS
* UNDERSTANDABLE TO ROUTINE WHICH USE S(3,3,48) AND T(3,48).
* THE VALUES IN S AND T ARE NOW 1 OR DECIMAL FRACTIONS.
*
      S(I,J,M)=SMAT(K,M)/12.0 
      T(I,M)=SMAT(I+12,M)/12.0
 7775 CONTINUE
C
C  ADD ORIGIN SHIFT 
C
      DO 7780 M=1,48
        DO 7777 I=1,3
          IF(S(I,I,M).LT.-0.001) THEN
            T(I,M)=T(I,M)+ISHIFT(I)/6.0 
            IF(T(I,M).GT.0.99) T(I,M)=T(I,M)-1.0
            IF(T(I,M).LT.-0.01) T(I,M)=T(I,M)+1.0 
            ENDIF
 7777     CONTINUE
 7780   CONTINUE
      IF(GCENT.EQ.GCHR(11)) CALL SYMD(S,T,NSYM,MSYM)
      IF(NDEBUG.NE.0) THEN
        NOUT1=NOUT
        NOUT=NDEBUG
        CALL SYMXYZ (NSYM,S,T)
        NOUT=NOUT1
        ENDIF
      RETURN
      END 
C
C
C
C
      SUBROUTINE SYMD(S,T,NSYM,MSYM)
C
C  *****SUBROUTINE*****           SYMD
C                                 ----
C
C WRITTEN 80.6.1 BY DOUG THIERS
C
C SUBROUTINE TO DOUBLE THE NUMBER OF SYM.OP.S FOR CENTROSYMETRIC S.G.S
C
      DIMENSION S(3,3,MSYM),T(3,MSYM)
      COMMON/FILES/NIN,NOUT,NDEBUG,NREAD,NWRITE,NSPGP
      DO 5 I=1,NSYM 
      IF(NSYM+I.LE.MSYM) GOTO 10
      WRITE(NOUT,100)
  100 FORMAT(40H ERROR IN SUBROUTINE:SYMD.MORE SYM OP.S
     1   ,40HCALCULATED THAN ALLOWED(48).                             )
      RETURN
   10 DO 15 J=1,3
      DO 25 K=1,3
   25 S(J,K,NSYM+I)=-S(J,K,I) 
   15 T(J,NSYM+I)=T(J,I)
    5 CONTINUE
      NSYM=2*NSYM
      RETURN
C**  THIS PROGRAM VALID ON FTN4 AND FTN5 **
      END 
C
C
C
C
      SUBROUTINE SYMXYZ(NSYM,S,T)
*
* WRITTEN BY DAVID R. MOSSCROP (7901822)
* MAY-JUNE ; 1982.
C 84.6.12 D. ALTERMATT
C
* FROM AN ARTICLE AND PROGRAM: NEW SPACE GROUP NAMES.
*      BY HALL 1982  REF:ACTA CRYST .A36, 517-523.
*
* CALLS INTEGER
*
* THIS SUBROUTINE PRINTS OUT THE SPACE GROUP TRANSFORMATIONS
* IN FAMILIAR X,Y,Z COORDINATES.
*
*
* TRANS IS A ONE DIMENSIONAL ARRAY OF 30 ELEMENTS 
* IN TRANS ONE TRANSFORMATION IS STORED BEFORE
* BEING PRINTED OUT IN XYZ FORM.
*
      IMPLICIT CHARACTER*8 (G)
      IMPLICIT CHARACTER*80 (H)
*
      INTEGER TRANS(30),INUM(7),CHR(26) 
      INTEGER SMAT(16,48)
      INTEGER BLNK,COMA,OVER,PLUS,SUBT
      DIMENSION S(3,3,NSYM), T(3,NSYM)
      COMMON /FILES/ NIN,NOUT 
      COMMON /GSYM/ GLAT,GCENT,HMSYM,HALL
      DATA BLNK,COMA,PLUS,SUBT,OVER/1H ,1H,,1H+,1H-,1H//
      DATA INUM/1H1,1H2,1H3,1H5,1H3,1H4,1H6/
      DATA CHR/1H1,1H2,1H3,1H4,1H5,1H6,1HP,1HR,1HA,1HB,1HC,1HI,1HF,     
     1  1HN,1HU,1HV,1HW,1HD,1H ,1H-,1HX,1HY,1HZ,1H*,1H',1H"/
*
* IN THIS ROUTINE NGEN IS EQUAL TO NSYM.
*
      IF (NSYM .GT. 0) GO TO 1021
      WRITE(NOUT,*)' NOTHING TO PRINT.' 
      RETURN
*
* EXTERNALLY THE ROTATIONS AND TRANSLATIONS ARE STORED AND
* MANIPULATED IN ARRAYS S(3,3,48) AND T(3,48) RESPECTIVELY. 
* IN SYMXYZ ( THIS ROUTINE ) THE ARRAY SMAT(16,48) SERVES
* AS STORAGE FOR BOTH THE ROTATIONS AND TRANSLATIONS.
*
 1021 DO 7775 M=1,NSYM
      DO 7775 J=1,3 
      DO 7775 I=1,3 
      K=4*(J-1)+I
      SMAT(K,M)=INTEGER((S(I,J,M)*12),0)
*
* MULTIPLICATION BY 12 IS NECESSARY TO CHANGE THE DECIMAL
* FRACTIONS OF S(3,3,48) AND T(3,48) INTO THE 12 THS
* WHICH THIS ROUTINE REQUIRES.
* 12 THS ARE USED BECAUSE THE TRANSLATION FRACTIONS
* (1/4, 1/3, 3/4, 1/2, 1/6, 5/6 ETC) ALL ARE NICE, IE EVEN
* MULTIPLIES OF 12. 
*
      SMAT(I+12,M)=INTEGER((T(I,M)*12),0)
 7775 CONTINUE
*
* PRINT HALL SPACE GROUP SYMBOL.
*
      WRITE(NOUT,100)   HALL
  100 FORMAT(' HALL SPACE GROUP SYMBOL = ',A15)
*
      WRITE(NOUT,105)
  105 FORMAT('    ')
      WRITE(NOUT,110)
  110 FORMAT(' SYMMETRY OPERATORS ')
      DO 20 M=1,NSYM
*
* PRESET ARRAY TRANS TO BLANKS.
*
      DO 21 I=1,30
      TRANS(I)=BLNK 
   21 CONTINUE
      N=1 
*
* EXTRACT TRANSLATIONAL ELEMENTS.
*
      DO 22 L=1,3
      J=SMAT(L+12,M)
C
C SPECIAL POSITION WITH COORDINATE(S) '0'
C
      NSUM=IABS(SMAT(4*L-3,M))+IABS(SMAT(4*L-2,M))+IABS(SMAT(4*L-1,M))
     1     +IABS(J) 
      IF(NSUM.EQ.0) THEN
         TRANS(N)=1H0
         N=N+1
         ENDIF
      IF (J.LE.0) GO TO 1017
*
* SET THE NUMERATOR AS ONE (1).
*
      IF (J.GE.8) GO TO 1014
      TRANS(N)=INUM(1)
      GO TO 1015
*
* SET NUMERATOR AS 2, 3 OR 5. 
*
 1014 TRANS(N)=INUM(J-6)
*
* INSERT SLASH INTO FRACTION. 
*
 1015 TRANS(N+1)=OVER
*
* POINT TO DENOMINATOR CODE.
*
      I=IABS(6-J)
      IF (J.NE.6) GO TO 1016
*
* SET DENOMINATOR AS TWO (2)
*
      TRANS(N+2)=INUM(2)
      GO TO 1020
*
* SET DENOMINTATOR AS 3, 4 OR 6
 1016 TRANS(N+2)=INUM(I+3)
 1020 N=N+3
 1017 DO 23 K=1,3
      J=L+(K-1)*4
      J=SMAT(J,M)
      IF (J.EQ.0) GO TO 23
      IF (J.LE.0) GO TO 1018
*
* INSERT PLUS SIGN. 
*
      TRANS(N)=PLUS 
      GO TO 1019
*
* INSERT NEGATIVE SIGN.
*
 1018 TRANS(N)=SUBT 
*
* INSERT X, Y, OR Z.
*
 1019 TRANS(N+1)=CHR(K+20)
      N=N+2
   23 CONTINUE
*
* SEPARATE WITH COMMA.
*
      TRANS(N)=COMA 
      N=N+1
   22 CONTINUE
*
* REMOVE THE LAST COMMA FROM THE OUTPUT.
*
      TRANS(N-1)=BLNK
*
* LIST SYMMETRY AS X,Y,Z.
*
      WRITE(NOUT,700)M,TRANS
  700 FORMAT(3X,I3,5X,30A1)
   20 CONTINUE
      RETURN
      END 
C
C
C
C
      SUBROUTINE GRMULT(IER)
C     -----------------
C
C   WRITTEN 84.1.13 BY I.D.BROWN
C
C   CALLS MXM AND ICOMMA
C
C***** CALLS TIME-FUNCTION =SECOND(I)=
C
C   THIS ROUTINE CALCULATES THE POINT GROUP MULTIPLICATION TABLE "MULT"
C   FROM THE ARRAY "S" IN /SYM/
C
      COMMON /FILES/ NIN,NOUT,NDEBUG
      COMMON /SYM/   NSYM,MSYM,S(3,3,48)
      COMMON /SYMA/  MULT(48,48),IT(3,48),NSP,MSP,ISPTAB(48,30)
C
      DIMENSION SS(3,3)
C
      IER=0
      DO 200 I=1,NSYM
        DO 150 J=1,NSYM
          CALL MXM(SS,S(1,1,J),S(1,1,I),3)
          DO 100 K=1,NSYM
            IF(ICOMMA(S(1,1,K),SS,3,2).EQ.0) THEN 
              MULT(I,J)=K
              GO TO 150
              ENDIF 
  100       CONTINUE
          WRITE(NOUT,1000) I,J
 1000     FORMAT(' ++ERROR++GRMULT++1000++ NO MATCH FOR PRODUCT OF'
     +     ,' SYMMETRY OPERATORS ',2I3) 
          IF(NDEBUG.NE.0) WRITE(NDEBUG,1001) SS
 1001     FORMAT(' ++DEBUG++GRMULT++1001++ ',9F6.2)
          IER=1
          RETURN
  150    CONTINUE
  200 CONTINUE
      IF(NDEBUG.NE.0) THEN
        WRITE(NDEBUG,1200) SECOND(3)
 1200   FORMAT(' ++DEBUG++GRMULT++1200++(',F6.2,') GROUP ', 
     + 'MULTIPLICATION TABLE')
        DO 220 I=1,NSYM
  220     WRITE(NDEBUG,1201) (MULT(I,J),J=1,NSYM) 
 1201     FORMAT(5X,40I3,/,10X,8I3)
        ENDIF
      RETURN
      END 
C
C
C
C
      SUBROUTINE SYMOP(Y,S,T,X)
C     ----------------
C
C   WRITTEN 84.2.8 BY I D BROWN
C
C   APPLIES THE SEITZ MATRIX S:T TO X TO GIVE Y
C
      DIMENSION X(3),Y(3),S(3,3),T(3)
      DO 50 I=1,3
        Y(I)=0.
        DO 20 J=1,3 
  20      Y(I)=Y(I)+S(I,J)*X(J)
        Y(I)=Y(I)+T(I)
   50   CONTINUE
      RETURN
      END 
C
C
C
C
      SUBROUTINE SYMULT(S3,T3,S2,T2,S1,T1)
C     -----------------
C
C   WRITTEN 84.2.8 BY I D BROWN
C
C   CALLS MXM, MXV, VPLUSV
C
C   CALCULATES (S/T)3=(S/T)2*(S/T)1
C
      DIMENSION S1(3,3),S2(3,3),S3(3,3),T1(3),T2(3),T3(3),T4(3)
      CALL MXM(S3,S2,S1,3)
      CALL MXV(T4,S2,T1)
      CALL VPLUSV(T3,T4,T2)
      RETURN
      END 
*
*
*
*
      SUBROUTINE WSCFS
*
* JULY 20-24 82 BY DAVID R. MOSSCROP / 84.6.5 D. ALTERMATT
* / 86.7.11 N. HEINIG /
*
* REDUCED TO SYMMETRY INFORMATIONS FOR =GETSPEC=
*
* CALLS INTEGER, INCREA
*
* THIS SUBROUTINE PRINTS THE COMMON BLOCK CONTENTS IN STANDARD
* FORMAT, AS DESCRIBED IN " THE STANDARD CRYSTALLOGRAPHIC FILE
* STRUCTURE" BY I. D. BROWN.(ACTA CRYST (1983) A39, 216-224).
*
*
      IMPLICIT CHARACTER*8 (G)
      IMPLICIT CHARACTER*80 (H)
*
      COMMON /FILES/ NIN,NOUT,NDEBUG,NREAD,NWRITE,NSPGP
      COMMON /SYM/   NSYM,MSYM,S(3,3,48),T(3,48)
      COMMON /GSYM/  GLAT,GCENT,HMSYM,HALL,GSYSP(2,30)
      COMMON /SYMA/  MULT(48,48),IT(3,48),NSPE,MSPE,ISPTAB(48,30),
     1               MUSP(30),SP(3,3,30),TSP(3,30)
*
* TITLE SECTION
*
      WRITE(NWRITE,1000) HALL,HALL
 1000 FORMAT(//,'TITLE   ',/,'* Symmetry Operators and Special ',
     1  'Positions for ',A15,5X,A8,/)
*
* CHECK FOR SPACE GROUP SYMBOL(S), EITHER HALL AND/OR HERMANN-MAUGUIN.
* FIRST CHECK IF BOTH ARE PRESENT.
*
      IF(HALL(1:7).NE.'       '.OR. HMSYM(1:7).NE.'       '
     *   .OR. GLAT.NE.' ' .OR. GCENT.NE.' ') THEN 
        WRITE(NWRITE, 1040)
 1040   FORMAT('SG NAME')
*
* AT LEAST ONE PRESENT
*
        IF(HALL(1:8).NE.'        ') WRITE(NWRITE,1060) HALL 
 1060   FORMAT(1X,'HALL',5X,A24)
        IF(HMSYM(1:8).NE.'        ') WRITE(NWRITE,1065) HMSYM
 1065   FORMAT(1X,'HERM',5X,A24)
        IF(GLAT.NE.' ' .OR. GCENT.NE.' ') WRITE(NWRITE,1070)GCENT,GLAT
 1070   FORMAT(1X,'LATT',5X,A1,A1)
        WRITE(NWRITE,1050)
 1050   FORMAT('*EOS',/)
	ENDIF
*
* CHECK FOR SYMMETRY OPERATORS.
*
      IF(NSYM.NE.0) THEN 
        WRITE(NWRITE,1080)
 1080   FORMAT('SYMMETRY')
        CALL INCREA
*
* CHECK FOR SPECIAL POSITION OPERATORS
*
        IF(NSPE.NE.0) THEN
          WRITE(NWRITE,1095)(((INTEGER(SP(I,J,K),0),J=1,3),TSP(I,K),
     *          I=1,3), K , MUSP(K),K=1,NSPE)
 1095     FORMAT((1X,'SPOS',5X,2(3I2,F10.7,4X),3I2,F10.7,I3,I2))
          ENDIF
        WRITE(NWRITE,1050)
        ENDIF
*
* WRITE 'END' CARD
*
      WRITE(NWRITE,2000)
 2000 FORMAT('END',//)
      RETURN
      END 
c
c
c
c
      SUBROUTINE INCREA
C
C   ****SUBROUTINE****     INCREA
C                           ------
C WRITTEN 86/06/05 BY NINA HEINIG
C
C WRITES OUT SYMMETRY TABLE
C
      IMPLICIT CHARACTER*8 (G)
C
      COMMON /SYM/ NSYM,MSYM,S(3,3,48),T(3,48),NLT,TU(3,4),GSYM
      COMMON /FILES/ NIN,NOUT,NDEBUG,NREAD,NWRITE,NSPGP
      COMMON /GSYM/ GLAT,GCENT
C
      IF(NDEBUG .NE. 0) WRITE(NDEBUG, 2000)NSYM,NLT,TU
 2000 FORMAT(' *DEBUG**INCREA*2000 NSYM,NLT,TU:',2I4,4(/,1X,3F5.0)) 
      DO 10 K=1,NSYM
        WRITE(NWRITE,1000)((INTEGER(S(I,J,K),0),J=1,3),T(I,K),I=1,3),K
 1000   FORMAT(1X,'SYOP',5X,2(3I2,F10.7,4X),3I2,F10.7,I3)
   10   CONTINUE
      RETURN
      END
c
c
c
c
      subroutine conxyz(sp,tp,hbuf)
c
c     written by D. Altermatt
c     McMaster University, Nov. 1984
c
c     calls integer
c
c     for a given operator (sp/tp) this subroutine constructs the
c     general representation with x,y,z as in the International 
c     Tables for Crystallograpy and as required by DLS
c
      implicit character*80 (h)
      character*8 g1(12),g2(12),g3(12),g4(12)
c
      dimension sp(3,3),tp(3)
      data g1/'1/8','1/4','3/8','1/2','5/8','3/4','7/8','1',4*'   '/
      data g2/'1/12','1/6','1/4','1/3','5/12','1/2','7/12','2/3',
     1        '3/4','5/6','11/12','1'/
      data g3/'9/8','5/4','11/8','3/2','13/8','7/4','15/8','2',4*' '/
      data g4/'13/12','7/6','5/4','4/3','17/12','3/2','19/12','5/3',
     1        '7/4','11/6','23/12','2'/
c
      hline=' '
      do 10 i=1,3
        j=(i-1)*17+1
        if((abs(sp(i,1))+abs(sp(i,2))+abs(sp(i,3))+abs(tp(i))).lt.
     1    0.01) then
c   --    i-th coordinate 0
          hline(j:j)='0'
          if(i.ne.3) hline(j+1:j+1)=','
          goto 10
          endif
        if(integer(sp(i,1),0).eq.0) goto 20
c   --    X-component
          hline(j+1:j+1)='X'
          if(sp(i,1).gt.1.01) hline(j:j)='2'
          if(sp(i,1).lt.-0.1) hline(j:j)='-'
20      if(integer(sp(i,2),0).eq.0) goto 30
c   --    Y-component
          hline(j+4:j+4)='Y'
          if(sp(i,2).gt.1.01) hline(j+3:j+3)='2'
          if(sp(i,2).lt.-0.1) hline(j+2:j+2)='-'
          if(hline(j+1:j+2).eq.'X ') hline(j+2:j+2)='+'
30      if(integer(sp(i,3),0).eq.0) goto 40
c   --    Z-component
          hline(j+7:j+7)='Z'
          if(sp(i,3).gt.1.01) hline(j+6:j+6)='2'
          if(sp(i,3).lt.-0.1) hline(j+5:j+5)='-'
          if(hline(j+5:j+5).eq.' '.and.hline(j:j+4).ne.'     ')
     1      hline(j+5:j+5)='+'
40      if(integer(tp(i),3).eq.0) goto 50
c   --    translation
          if(hline(j:j+7).ne.'       ') hline(j+8:j+8)='+'
          if(tp(i).lt.-0.1) hline(j+8:j+8)='-'
          do 45 k=1,12
            xk=k
            k1=k*125
            k2=integer((xk*83.33),0)
            if(iabs(integer(tp(i),3)).eq.k1) 
     1        hline(j+9:j+14)=g1(k)(1:6)
            if(iabs(integer(tp(i),3)).eq.(k1+1000))
     1        hline(j+9:j+14)=g3(k)(1:6)
            if(iabs(integer(tp(i),3)).eq.k2) 
     1        hline(j+9:j+14)=g2(k)(1:6)
            if(iabs(integer(tp(i),3)).eq.(k2+1000))
     1        hline(j+9:j+14)=g4(k)(1:6)
45          continue
50        if(i.ne.3) hline(j+15:j+15)=','
10      continue
c
c     remove blanks, store in hbuf
c
      hbuf=' '
      j=1
      do 100 i=1,80
        if(hline(i:i).eq.' ') goto 100
        hbuf(j:j)=hline(i:i)
        j=j+1
100     continue
      return
      end
C
C
C
      SUBROUTINE MMINM(C,A,B,N)
C     -------------------------
C
C   WRITTEN 84.1.25 BY I.D.BROWN
C
C   CALCULATES C(N,N)=A(N,N)-B(N,N)
C
      DIMENSION A(N,N),B(N,N),C(N,N)
      DO 50 I=1,N
        DO 50 J=1,N 
   50     C(I,J)=A(I,J)-B(I,J)
      RETURN
      END 
*
*
*
*
      SUBROUTINE MXM (C,A,B,N)
*---- CALCULATES THE MATRIX PRODUCT FOR N*N MATRICES AS
*     A * B = C
*
*     A, B   INPUT MATRICES
*     C      OUTPUT MATRIX
*     N      ORDER OF MATRICES
*
*     WRITTEN BY D. ALTERMATT 
*---- MCMASTER UNIVERSITY, DAWN OF ORWELL'S YEAR
      DIMENSION A(N,N),B(N,N),C(N,N)
      DO 10 I=1,N
      DO 20 K=1,N
      C(I,K)=0
      DO 30 J=1,N
      C(I,K)=C(I,K)+A(I,J)*B(J,K)
   30 CONTINUE
   20 CONTINUE
   10 CONTINUE
      RETURN
      END 
C
C
C
C
      SUBROUTINE MXV(VPROD,SM,V)
C
C  *****SUBROUTINE*****     MXV
C                           ---
C
C   WRITTEN 83.9.7 BY I D BROWN
C
C   CALCULATES VPROD(3) = SM(3,3)*V(3)
C
      DIMENSION VPROD(3),SM(3,3),V(3)
      DO 50 I=1,3
         VPROD(I) = 0
         DO 50 J=1,3
   50       VPROD(I) = VPROD(I) + SM(I,J)*V(J)
      RETURN
      END 
*
*
*
*
*
      FUNCTION ICOMMA (A,B,N,ID)
*---- COMPARES TWO N*N MATRICES, GIVES ICOMMAT=0 IF THEY
*     ARE EQUIVALENT WITHIN ID DECIMAL PLACES, ELSE ICOMMAT=1
*
*     CALLS INTEGER
*
*     A, B  MATRICES TO CHECK 
*     N     ORDER OF MATRICES 
*     ID    NUMBER OF DECIMAL PLACES TO CHECK
*
*     WRITTEN BY D. ALTERMATT 
*     MODIFIED 84.5.16 BY I D BROWN
*---- MCMASTER UNIVERSITY, DAWN OF ORWELL'S YEAR
      DIMENSION A(N,N),B(N,N) 
      ICOMMA=0
      DO 10 I=1,N
      DO 20 J=1,N
        IF(INTEGER(A(I,J),ID).NE.INTEGER(B(I,J),ID)) THEN
          ICOMMA=1 
          RETURN
          ENDIF
   20 CONTINUE
   10 CONTINUE
   99 RETURN
      END 
C
C
C
C
      FUNCTION ICOMVE (X,Y,N,ID)
C     --------------------------
C
C   WRITTEN 84.2.7 BY I D BROWN
C
C   RETURNS THE VALUE OF 0 IF X(N) AND Y(N) ARE IDENTICAL TO ID DECIMAL
C   PLACES
C
      DIMENSION X(N),Y(N)
      ICOMVE=0
      DO 100 I=1,N
  100   IF(INTEGER(X(I),ID).NE.INTEGER(Y(I),ID)) ICOMVE=1
      RETURN
      END 
C
C
C
C
      FUNCTION INTEGER(X,N)
C
C   *****FUNCTION*****     INTEGER
C                          -------
C
C   WRITTEN 81.1.7 BY I D BROWN
C
C   RETURNS THE VALUE OF X*10**N AS THE NEAREST INTEGER
C
      Y = 1
      IF(N.LT.1) GO TO 20
      DO 10 I=1,N
   10    Y = Y*10.
   20 IF(X.LT.0.) GO TO 30
      INTEGER = X*Y + 0.5
      RETURN
   30 INTEGER = X*Y - 0.5
      RETURN
C**  THIS PROGRAM VALID ON FTN4 AND FTN5 **
      END 
C
C
C
*
      function second (itype)
*
*---  system dependent runtime call function, VAX-version
*
*     itype = 1      initialize system timer
*           = 2      print elapsed CPU time to SYS$OUTPUT
*           = 3      return elapsed CPU time
*
*     written by Daniel Altermatt
*---  McMaster University, September 1984
*
      external LIB$INIT_TIMER
      external LIB$STAT_TIMER
      external LIB$SHOW_TIMER
      character*80 htime
*
      second = 0.0
      if (itype.ne.1) goto 10
      call LIB$INIT_TIMER(it)
      return
*
10    if (itype.ne.2) goto 20
      icode = 2
      call LIB$SHOW_TIMER(it,icode,,htime)
      return
*
20    icode = 2
      call LIB$STAT_TIMER(icode,itime,it)
      second = itime / 100.
      return
      end
C
C
C
C
*     function second (itype)
C
C---  system dependent runtime call function, CYBER-version
C
C     itype = 1      initialize system timer
C           = 2      print elapsed CPU time to SYS$OUTPUT
C           = 3      return elapsed CPU time
C
C     written by Daniel Altermatt
C---  McMaster University, June 1985
C
*     EXTERNAL SECOND()
C
*     IF (ITYPE.LE.1) THEN
*        SECOND = 0.0
*     ELSE IF (ITYPE.EQ.2) THEN
*        WRITE(OUTPUT,1000) SECOND()
*1000    FORMAT(10X,'ELAPSED CPU-TIME SINCE START: ',F10.2,' SECONDS')
*     ELSE
*        SECOND = SECOND()
*        ENDIF
*     RETURN
*     END
C
C
C
C
      SUBROUTINE VMINV(Z,X,Y)
C
C   *****SUBROUTINE***** VMINV
C                        -----
C
C   WRITTEN 83.9.23 BY I D BROWN
C
C   CLACULATES Z(3) = X(3)-Y(3)
C
      DIMENSION X(3),Y(3),Z(3)
      DO 10 I=1,3
   10   Z(I) = X(I) - Y(I)
      RETURN
      END 
C
C
C
C
      SUBROUTINE VPLUSV(VPROD,V1,V2)
C
C   ******SUBROUTINE******    VPLUSV
C                             ------
C
C   WRITTEN 89.9.7 BY I D BROWN
C
C   CALCULATES VPROD(3) = V1(3) + V2(3) 
C
      DIMENSION VPROD(3),V1(3),V2(3)
      DO 50 I=1,3
   50    VPROD(I) = V1(I) + V2(I)
      RETURN
      END 

