      SUBROUTINE CMSFIL
C
C     THIS SUBROUTINE GENERATES THE WORKING SUBSTRUCTURE FILE AND
C     APPLIES ALL TRANSFORMATIONS
C
      EXTERNAL        RSHIFT,ANDF
      LOGICAL         TDAT,XTRAN,XCSTM,IAUTO
CWKBI ALPHA-OSF 9/94
      INTEGER         SCR3, SCSFIL
      INTEGER         AAA(2),ANDF,RSHIFT,BUFEX,OUTT,
     1                SCBDAT,BUF4,SCORE,TRN,SYM,COMBO,NAM(2),Z,SCMCON,
     2                SCCSTM,CSTMID,CGID,BUF2,BUF3,BUF1,ECPT1,TWOJM1
      DIMENSION       RZ(1),ECPT(4),DOFN(6),LIST(32),TG(3,3),TG6(6,6),
     1                TSAVE(6,6),TMAT(6,6),TC(3,3),TT(3,3),XX(3)
      COMMON /CMB001/ SCR1,SCR2,SCBDAT,SCSFIL,SCCONN,SCMCON,SCTOC,
     1                GEOM4,CASECC,SCCSTM,SCR3
      COMMON /CMB002/ BUF1,BUF2,BUF3,BUF4,BUF5,SCORE,LCORE,INTP,OUTT
      COMMON /CMB003/ COMBO(7,5),CONSET,IAUTO,TOLER,NPSUB,CONECT,TRAN,
     1                MCON,RESTCT(7,7),ISORT,ORIGIN(7,3),IPRINT
      COMMON /CMB004/ TDAT(6)
      COMMON /GTMATX/ LOC1,KLTRAN,TRN,TT6(6,6),TC6(6,6)
      COMMON /ZZZZZZ/ Z(1)
      EQUIVALENCE     (ECPT1,ECPT(1)), (RZ(1),Z(1))
      DATA    AAA   / 4H CMS, 4HFIL  /
      DATA    NHBGSS, NHCSTM,NHEQSS  / 4HBGSS,4HCSTM,4HEQSS /
C
      BUFEX  = LCORE - BUF1 + BUF2
      LCORE  = BUFEX - 1
      IF (LCORE .LT. 0) GO TO 620
      LLCO   = LCORE
      IOEFIL = 310
      IFILE  = SCBDAT
      CALL OPEN (*600,SCBDAT,Z(BUF4),0)
C
C     READ GTRAN DATA INTO OPEN CORE
C
      IF (TDAT(3) .OR. TDAT(6)) CALL SKPFIL (SCBDAT,1)
      IF (.NOT.TDAT(6)) GO TO 20
      KSGTRN = SCORE
      CALL READ (*610,*10,SCBDAT,Z(KSGTRN),LLCO,1,KLGTRN)
      GO TO 620
   10 LLCO   = LLCO - KLGTRN
      KFGTRN = KSGTRN + KLGTRN - 1
      GO TO 30
C
C     READ TRANS DATA INTO OPEN CORE
C
   20 KSTRAN = SCORE
      GO TO 40
   30 KSTRAN = KFGTRN + 1
   40 IF (TDAT(3) .OR. TDAT(6)) CALL SKPFIL (SCBDAT,1)
      IF (.NOT. TDAT(3)) GO TO 60
      CALL READ (*610,*50,SCBDAT,Z(KSTRAN),LLCO,1,KLTRAN)
      GO TO 620
   50 LOC1   = KSTRAN
      LLCO   = LLCO - KLTRAN
      XTRAN  = .TRUE.
      KFTRAN = KSTRAN + KLTRAN - 1
      GO TO 70
   60 LOC1   = 0
      XTRAN  = .FALSE.
   70 CALL CLOSE (SCBDAT,1)
      IFILE  = SCSFIL
      CALL OPEN (*600,SCSFIL,Z(BUF4),1)
      IFILE  = SCCSTM
      CALL OPEN (*600,SCCSTM,Z(BUF3),1)
      KKC    = 0
C
C     LOOP ON EACH PSEUDOSTRUCTURE
C
      IFILE  = SCR3
      CALL OPEN (*600,SCR3,Z(BUF1),1)
      IFILE  = IOEFIL
      CALL OPEN (*600,IOEFIL,Z(BUFEX),1)
      LLCOLD = LLCO
C
      DO 550 I = 1,NPSUB
      LLCO   = LLCOLD
      NAM(1) = COMBO(I,1)
      NAM(2) = COMBO(I,2)
      TRN    = COMBO(I,3)
      SYM    = COMBO(I,4)
      NCOMP  = COMBO(I,5)
C
C     READ BGSS FOR I-TH PSEUDOSTRUCTURE
C
      KSBGSS = KSTRAN
      IF (XTRAN) KSBGSS = KSTRAN + KLTRAN
      CALL SFETCH (NAM,NHBGSS,1,ITEST)
      NGRP   = 1
      CALL SJUMP (NGRP)
      CALL SUREAD (Z(KSBGSS),LLCO,KLBGSS,ITEST)
      IF (KLBGSS.EQ.LLCO .AND. ITEST.NE.2) GO TO 620
      LLCO   = LLCO - KLBGSS
      KFBGSS = KSBGSS + KLBGSS - 1
      NIP    = KLBGSS/4
C
C     READ CSTM FOR THIS PSEUDOSTRUCTURE
C
      CALL SFETCH (NAM,NHCSTM,1,ITEST)
      XCSTM  = .FALSE.
      LOC2   = 0
      IF (ITEST .EQ. 3) GO TO 80
      KSCSTM = KFBGSS + 1
      NGRP   = 1
      CALL SJUMP (NGRP)
      CALL SUREAD (Z(KSCSTM),LLCO,KLCSTM,ITEST)
      IF (KLCSTM.EQ.LLCO .AND. ITEST.NE.2) GO TO 620
      LLCO   = LLCO - KLCSTM
      LOC2   = KSCSTM
      XCSTM  = .TRUE.
      KFCSTM = KSCSTM + KLCSTM - 1
   80 CONTINUE
C
C     DEFINE OPEN CORE ARRAYS FOR NEW CID AND HPTR
C
      KSNCID = KFBGSS + 1
      IF (LOC2 .NE. 0) KSNCID = KFCSTM + 1
      KLNCID = NIP
      LLCO   = LLCO - KLNCID
      KFNCID = KSNCID + KLNCID - 1
C
      KSHPTR = KFNCID + 1
      KLHPTR = NIP
      LLCO   = LLCO - KLHPTR
      KFHPTR = KSHPTR + KLHPTR - 1
C
C     SET ARRAYS TO ZERO
C
      DO 90 J = KSNCID,KFNCID
      Z(J) = 0
   90 CONTINUE
      DO 100 J = KSHPTR,KFHPTR
      Z(J) = 0
  100 CONTINUE
C
C     GET THE TRANS AND SYMT MATRIX FOR THIS PSEUDOSTRUCTURE
C
      CALL GTMAT1 (SYM,TT)
C
C     TRANSFORM THE COORDINATES IN THE BGSS, NOTE THAT THE ORIGINS
C     FOR TRANSLATION ARE STORED IN ARRAY ORIGIN.
C
      IF (TRN+SYM .EQ. 0) GO TO 130
      DO 120 J = KSBGSS,KFBGSS,4
      IF (Z(J) .EQ. -1) GO TO 120
      CALL GMMATS (TT,3,3,0 ,RZ(J+1),3,1,0 ,XX)
      DO 110 JJ = 1,3
      RZ(J+JJ) = XX(JJ) + ORIGIN(I,JJ)
  110 CONTINUE
  120 CONTINUE
  130 CONTINUE
C
C     TRANSFORM DEGREES OF FREEDOM FOR EACH EQSS CONTAINED
C     IN THE PSEUDOSTRUCTURE.
C
      CALL WRITE (SCR3,TT6,36,1)
      NHMAT = 1
      CALL SFETCH (NAM,NHEQSS,1,ITEST)
      KNEQSS = KFHPTR + 1
      CALL SUREAD (Z(KNEQSS),4,KLEQSS,ITEST)
      CALL SUREAD (Z(KNEQSS),-1,KLEQSS,ITEST)
      LLCO  = LLCO - 2*NCOMP
      IFILE = SCMCON
      CALL OPEN (*600,SCMCON,Z(BUF2),1)
      DO 350 J = 1,NCOMP
      KSEQSS = KFHPTR + 2*NCOMP
      CALL SUREAD (Z(KSEQSS),LLCO,KLEQSS,ITEST)
      IF (KLEQSS .EQ. 0) GO TO 340
      IF (KLEQSS.EQ.LLCO .AND. ITEST.NE.2) GO TO 620
      KFEQSS = KSEQSS + KLEQSS - 1
C
C     LOOP ON EACH IP IN THE EQSS AND GENERATE TRANSFORMATION MATRIX
C
      DO 330 JJ = KSEQSS,KFEQSS,3
      IP    = Z(JJ+1)
      ICOMP = Z(JJ+2)
C
C     GET CSTM FOR THIS IP
C
      CSTMID = Z(KSBGSS+4*IP-4)
      ECPT1  = CSTMID
      IF (CSTMID .LT. 0) ECPT1 = 0
      DO 140 JDH = 1,3
      ECPT(JDH+1) = RZ(KSBGSS+4*IP-4+JDH)
  140 CONTINUE
      CALL GTMAT2 (LOC2,KLCSTM,ECPT,TC)
C
C     TEST FOR POSSIBLE GTRAN
C
      IGTRAN = 0
      IF (.NOT.TDAT(6)) GO TO 170
      CGID = 1000000*J + Z(JJ)
      DO 150 K = KSGTRN,KFGTRN,5
      IF (Z(K+3).EQ.CGID .AND. Z(K).EQ.I .AND. Z(K+1).EQ.J) GO TO 160
  150 CONTINUE
C
C     NO GTRAN
C
      GO TO 170
  160 CALL GTMAT3 (Z(K+4),TG,TG6,IKIND)
      IGTRAN = 1
      GO TO 180
  170 CALL GTMAT3 (-1,TG,TG6,IKIND)
C
C     ALL TRANSFORMATIONS HAVE BEEN FOUND, COMPUTE THE FINAL MATRIX TMAT
C
  180 CALL GMMATS (TG6  ,6,6,1,TT6,6,6,0,TSAVE)
      CALL GMMATS (TSAVE,6,6,0,TC6,6,6,0,TMAT )
C
C     DECODE DEGREES OF FREEDOM AND FORM VECTOR
C
      CALL DECODE (ICOMP,LIST,NDOF)
C
C     FIND NEW DEGREES OF FREEDOM AND UPDATE EQSS
C
      IF (CSTMID.NE.0 .AND. IGTRAN.EQ.0) GO TO 220
      DO 200 I1 = 1,6
      DOFN(I1) = 0.0
      DO 190 I2 = 1,NDOF
      L = LIST(I2) + 1
      IF (ABS(TMAT(L,I1)) .LT. 1.0E-4) GO TO 190
      DOFN(I1) = 1.0
      GO TO 200
  190 CONTINUE
  200 CONTINUE
      ICODE = 0
      DO 210 I1 = 1,6
      ICODE = ICODE + DOFN(I1)*2**(I1-1)
  210 CONTINUE
      GO TO 230
  220 ICODE   = ICOMP
  230 Z(JJ+2) = ICODE
C
C     WRITE IP,C ON SCRATCH TO COMPUTE NEW SIL,C
C
      CALL WRITE (SCMCON,IP,1,0)
      CALL WRITE (SCMCON,ICODE,1,0)
C
C     UPDATE CID NUMBERS
C
      IADD   = KSBGSS + 4*IP - 4
      IADD1  = KSNCID + IP - 1
      IKKIND = IKIND  + 1
      GO TO (240,240,250,250,240,240,260,260,290,290,290,290,270,270,
     1       280,280,290,290,290,290,290,290,290,290,290,290,290,290,
     2       280,280,280,280,280,280,280), IKKIND
  240 Z(IADD1) = Z(IADD)
      IF (Z(IADD) .EQ. -1) Z(IADD1) = -100000000
      IF (Z(IADD) .EQ. -2) Z(IADD1) = -200000000
      GO TO 290
C
C     COMMENTS FROM G.CHAN/UNISYS  9/92
C     250 AND 240 ARE IDENTICAL HERE. IS IT POSSIBLY AN ERROR HERE?
C
  250 Z(IADD1) = Z(IADD)
      IF (Z(IADD) .EQ. -1) Z(IADD1) = -100000000
      IF (Z(IADD) .EQ. -2) Z(IADD1) = -200000000
      GO TO 290
  260 Z(IADD1) = 0
      GO TO 290
  270 Z(IADD1) = -TRN
      GO TO 290
  280 Z(IADD1) = -Z(K+4)
  290 CONTINUE
C
C     SET POINTERS FOR H MATRIX
C
      ITIS = 0
      IADD2 = KSHPTR + IP - 1
      IF (CSTMID   .LT. 0) GO TO 300
      IF (Z(IADD2) .GT. 2) GO TO 330
      IF (IKKIND.EQ. 3 .OR. IKKIND.EQ.4 .OR. IKKIND.EQ.13 .OR.
     1    IKKIND.EQ.14) ITIS = 1
      IF (IKKIND.EQ. 1 .OR. IKKIND.EQ.2 .OR. IKKIND.EQ. 5 .OR.
     1    IKKIND.EQ. 6) ITIS = 2
      IF (ITIS - 1) 320,300,310
  300 Z(IADD2) = 0
      GO TO 330
  310 Z(IADD2) = 1
      GO TO 330
  320 CONTINUE
      NHMAT = NHMAT + 1
      Z(IADD2) = NHMAT
      CALL WRITE (SCR3,TMAT,36,1)
  330 CONTINUE
C
C     INSERT MULTIPLE IP CODE
C
      IF (NCOMP .NE. 1) CALL EQSCOD (KSEQSS,KLEQSS,Z(1))
C
C     WRITE EQSS ON FILE SCSFIL
C
  340 CALL WRITE (SCSFIL,Z(KSEQSS),KLEQSS,1)
      TWOJM1 = 2*(J-1)
      IF (ANDF(RSHIFT(IPRINT,19),1) .EQ. 1)
     1    CALL CMIWRT (1,NAM,Z(KNEQSS+TWOJM1),KSEQSS,KLEQSS,Z,Z)
  350 CONTINUE
      CALL EOF (SCR3)
      CALL CLOSE (SCMCON,1)
C
C     GENERATE NEW SIL,C LIST
C
      IFILE = SCMCON
      CALL OPEN (*600,SCMCON,Z(BUF2),0)
      CALL READ (*360,*360,SCMCON,Z(KSEQSS),LLCO,1,NNN)
      GO TO 620
  360 CALL SORT (0,0,2,1,Z(KSEQSS),NNN)
      KSEJ = KSEQSS + NNN - 1
      I1 = KSEQSS
      I2 = KSEQSS + 2
  370 IF (I2-KSEQSS .GE. NNN) GO TO 400
      IF (Z(I1)   .EQ. Z(I2)) GO TO 380
      I1 = I1 + 2
      I2 = I2 + 2
      GO TO 370
  380 DO 390 J = I2,KSEJ
  390 Z(J-2) = Z(J)
      KSEJ = KSEJ - 2
      NNN  = NNN  - 2
      GO TO 370
  400 CONTINUE
      Z(KSEQSS) = 1
      DO 410 J = 3,NNN,2
      JJ = J - 1
      ICODE = Z(KSEQSS+JJ-1)
      CALL DECODE (ICODE,LIST,NDOF)
      Z(KSEQSS+JJ) = Z(KSEQSS+JJ-2) + NDOF
  410 CONTINUE
      CALL WRITE  (SCSFIL,Z(KSEQSS),NNN,1)
      CALL SUREAD (Z(KSEQSS),LLCO,KLEQSS,ITEST)
      CALL WRITE  (IOEFIL,Z(KSEQSS),KLEQSS,1)
      CALL CLOSE  (SCMCON,1)
C
C     PRINT EQSS SIL LIST IF REQUESTED
C
      IF (ANDF(RSHIFT(IPRINT,19),1) .EQ. 1)
     1    CALL CMIWRT (8,NAM,0,KSEQSS,KLEQSS,Z,Z)
C
C     UPDATE CSTM NUMBERING SYSTEM
C     KKC IS TRANSFORMED SYSTEM COORD. ID
C
      IP  = 0
      DO 540 I6 = KSNCID,KFNCID
      IP  = IP + 1
      LOC = KSBGSS + 4*(IP-1)
      IF (Z(I6) .EQ. 100000000) GO TO 540
      IF (Z(I6)) 430,520,420
  420 I1  = KSCSTM
      I2  = KFCSTM
      GO TO 440
  430 IF (Z(I6) .EQ. -100000000) GO TO 530
      I1  = KSTRAN
      I2  = KFTRAN
  440 KKC = KKC + 1
      IF (IAUTO) GO TO 480
      IF (KKC .GT. 1) GO TO 460
      CALL PAGE1
      CALL PAGE2 (5)
      WRITE  (OUTT,450)
  450 FORMAT (//45X,'SUMMARY OF OVERALL SYSTEM COORDINATES', //36X,
     1      'PSEUDO STRUCTURE ID.   SYSTEM COORD.ID    USER COORD.ID',/)
  460 CALL PAGE2 (1)
      WRITE  (OUTT,470) I,KKC,Z(LOC)
  470 FORMAT (43X,I6,14X,I6,11X,I6)
  480 LOOK4 = Z(I6)
      DO 500  J6 = I1,I2,14
      IF (IABS(Z(I6)) .NE. Z(J6)) GO TO 500
      IF (Z(I6) .LE. 0) GO TO 490
      CALL GMMATS (TT,3,3,0,Z(J6+5),3,3,0,TC)
      CALL WRITE (SCCSTM,KKC,1,0)
      CALL WRITE (SCCSTM,Z(J6+1),4,0)
      CALL WRITE (SCCSTM,TC,9,0)
      GO TO 500
  490 CONTINUE
      CALL WRITE (SCCSTM,KKC,1,0)
      CALL WRITE (SCCSTM,Z(J6+1),13,0)
  500 CONTINUE
C
C     FIND OTHER CIDS THAT ARE THE SAME
C
      IIP = 0
      DO 510 J6 = KSNCID,KFNCID
      IIP = IIP + 1
      IF (Z(J6).NE. LOOK4) GO TO 510
      LOC = KSBGSS + 4*(IIP-1)
      Z(LOC) = KKC
      Z(J6) = 100000000
  510 CONTINUE
      GO TO 540
  520 Z(LOC) = 0
      GO TO 540
  530 Z(LOC) = -1
      IF (Z(I6) .EQ. -200000000) Z(LOC) = -2
  540 CONTINUE
C
C     WRITE PROCESSED BGSS
C
      CALL WRITE (SCSFIL,Z(KSBGSS),KLBGSS,1)
      IF (ANDF(RSHIFT(IPRINT,18),1) .EQ.  1)
     1    CALL CMIWRT (2,NAM,NAM,KSBGSS,KLBGSS,Z(1),Z(1) )
C
C     WRITE ARRAY OF H POINTERS
C
      CALL WRITE (SCSFIL,Z(KSHPTR),KLHPTR,1)
      CALL EOF (SCSFIL)
  550 CONTINUE
C
      CALL CLOSE (SCR3,1)
      CALL CLOSE (SCSFIL,1)
      CALL WRITE (SCCSTM,TMAT,0,1)
      CALL CLOSE (SCCSTM,1)
      CALL CLOSE (IOEFIL,1)
      LCORE = BUFEX + BUF1 - BUF2
      RETURN
C
  600 IMSG = -1
      GO TO 630
  610 IMSG = -2
      GO TO 630
  620 IMSG = -8
  630 CALL MESAGE (IMSG,IFILE,AAA)
      RETURN
      END
