PSI sics-cvs-psi_pre-ansto

2003-06-13 00:00:00 +00:00
parent 2e3ddfb6c6
commit 3ffd0d8af4
1099 changed files with 318432 additions and 0 deletions
--- a/difrac/sgprnh.f
+++ b/difrac/sgprnh.f
@@ -0,0 +1,125 @@
+C-----------------------------------------------------------------------
+C  Space group routine printing
+C-----------------------------------------------------------------------
+      SUBROUTINE SGPRNT (SPG,JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN,
+     $                   NCV,LPT)
+      CHARACTER COUT*132
+      COMMON /IOUASC/ COUT(20)
+      DIMENSION SPG(10),JRT(3,4,25),CEN(3,4),NCVT(7),CENV(3,6),NSYS(14)
+      CHARACTER*3 POLAR(8)
+      CHARACTER*4 LTYP(3,7),SYST(3,8),LAUE(2,14)
+      CHARACTER*1 NAX(3),NC(2)
+      CHARACTER CHKL(3)*2,CTEM*4,OUTL(3)*20
+      DATA CHKL/'+h','+k','+l'/
+      DATA LTYP/'  Pr','imit','ive ',
+     $          ' A-C','ente','red ',' B-C','ente','red ',
+     $          ' C-C','ente','red ',' I-C','ente','red ',
+     $          ' F-C','ente','red ',' R-C','ente','red '/
+      DATA SYST/'Tric','lini','c   ','Mono','clin','ic  ',
+     $          'Orth','orho','mbic','Tetr','agon','al  ',
+     $          'Rhom','bohe','dral','Trig','onal','    ',
+     $          'Hexa','gona','l   ','Cubi','c   ','    '/
+      DATA LAUE/'1bar','    ','2/m ','    ','mmm ','    ','4/m ','    ',
+     $          '4/mm','m   ','3bar','    ','3bar',' M  ','3bar','    ',
+     $          '3bar','m 1 ','3bar','1 m ','6/m ','    ','6/mm','m   ',
+     $          'M 3 ','    ','M 3 ','M   '/
+      DATA POLAR/'x','y','x y','z','x z','y z','xyz','111'/
+      DATA NAX/'a','b','c'/
+      DATA NSYS/1,2,3,4,4,5,5,6,6,6,7,7,8,8/
+      DATA NC/'A',' '/
+      DATA NCVT/1,2,2,2,2,4,3/
+      DATA CENV/  0,0.5,0.5,  0.5,0,0.5,  0.5,0.5,0,  0.5,0.5,0.5,
+     $      0.3333333,0.6666667,0.6666667,0.6666667,0.3333333,0.3333333/
+      NCV = NCVT(LCENT)
+      MULT = NCV*NSYM*(NCENT + 1)
+      LSYS = NSYS(LAUENO)
+      DO 90 I = 1,3
+        CEN(I,1) = 0.0
+        OUTL(I) = ' '
+   90 CONTINUE
+      IF (NCV .LE. 1) GO TO 110
+      J = LCENT - 1
+      IF (LCENT .EQ. 6) J = 1
+      IF (LCENT .EQ. 7) J = 5
+        DO 100 I = 2,NCV
+        CEN(1,I) = CENV(1,J)
+        CEN(2,I) = CENV(2,J)
+        CEN(3,I) = CENV(3,J)
+        J = J + 1
+  100   CONTINUE
+  110 CONTINUE
+      NPX = 1
+      NPY = 2
+      NPZ = 4
+      NPXYZ = 0
+      NPYXZ = 1
+        DO 120 I = 1,NSYM
+        IF (JRT(1,1,I) .LE. 0) NPX = 0
+        IF (JRT(2,2,I) .LE. 0) NPY = 0
+        IF (JRT(3,3,I) .LE. 0) NPZ = 0
+        IF (JRT(1,3,I) .GT. 0) NPXYZ = 8
+        IF (JRT(1,3,I) .LT. 0) NPYXZ = 0
+  120   CONTINUE
+      NPOL = (NPX + NPY + NPZ + NPXYZ*NPYXZ)*(1 - NCENT)
+      IF (LPT .LT. 0) RETURN
+      WRITE (COUT,10000) SPG,NC(NCENT + 1),
+     $                  LTYP(1,LCENT),LTYP(2,LCENT),LTYP(3,LCENT),
+     $                  SYST(1,LSYS),SYST(2,LSYS),SYST(3,LSYS),
+     $                  LAUE(1,LAUENO),LAUE(2,LAUENO),MULT
+      CALL GWRITE (LPT,' ')
+      IF (NAXIS .GT. 0) THEN
+        WRITE (COUT,11000) NAX(NAXIS)
+        CALL GWRITE (LPT,' ')
+      ENDIF
+      IF (NPOL  .GT. 0) THEN
+        WRITE (COUT,12000) POLAR(NPOL)
+        CALL GWRITE (LPT,' ')
+      ENDIF
+      WRITE (COUT,13000)
+      CALL GWRITE (LPT,' ')
+      KI = 0
+      KL = 2
+      IF (LAUENO .GT. 5) KL = 3
+      DO 140 I = 1,NSYM
+        KI = KI + 1
+        DO 135 J = 1,3
+          L = 1
+          CTEM = ' ' 
+          DO 130 K = 1,3
+            IF (JRT(K,J,I) .NE. 0) THEN
+              CTEM(L:L+1) = CHKL(K)
+              IF (JRT(K,J,I) .EQ. -1) CTEM(L:L) = '-'
+              L = L + 2
+            ENDIF
+  130     CONTINUE
+          IF (CTEM(1:1) .EQ. '+') CTEM(1:1) = ' '
+          MC = L - 1
+          M = 1 + 6*(J - 1) + 4 - MC
+          OUTL(KI)(M:M+MC-1) = CTEM(1:MC)
+  135   CONTINUE
+        IF (KI .EQ. KL) THEN
+          WRITE (COUT,15000) (OUTL(K),K = 1,KL)
+          CALL GWRITE (LPT,' ')
+          KI = 0
+          DO 137 K = 1,3
+            OUTL(K) = ' '
+  137     CONTINUE
+        ENDIF
+  140 CONTINUE
+      IF (LAUENO .EQ. 1) THEN
+        WRITE (COUT,15000) (OUTL(I),I = 1,3)
+        CALL GWRITE (LPT,' ')
+      ENDIF
+      WRITE (COUT,14000)
+      CALL GWRITE (LPT,' ')
+      RETURN
+10000 FORMAT (/' Space Group ',10A1/
+     $        '  The Space Group is ',A1,'Centric',6A4,
+     $        '  Laue Symmetry ',2A4/
+     $        '  Multiplicity of a General Site is',I4)
+11000 FORMAT ('  The Unique Axis is ',A1)
+12000 FORMAT ('  The location of the origin is arbitrary in ',A3)
+13000 FORMAT (/' Space-group Equivalent Reflections are:')
+14000 FORMAT (' Friedel Reflections are the -,-,- of these.'/'%')
+15000 FORMAT (5X,3(A20,3X))
+      END