SUBROUTINE GIPRD(KHANEL,NATOMS,NN,A,NA,NB,NC,IOERR ) IMPLICIT REAL (A-H,O-Z) INCLUDE 'SIZES' CHARACTER*80 KEYWRD,KOMENT,TITLE,COMAND, DUMMY CHARACTER*6 ATSYMB LOGICAL ERROR COMMON /INTCOR/ XNDOGM(3, NUMATM), INTFRE(3, NUMATM) COMMON/KEYS/ KEYWRD,KOMENT,TITLE LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI C C ROUTINE TO READ A .GIP INTERMEDIATE FILE C DIMENSION X(NUMATM), Y(NUMATM), Z(NUMATM), NA(NUMATM), . NB(NUMATM),NC(NUMATM) DIMENSION NN(NUMATM),A(3,NUMATM) MAXATM=NUMATM IOERR=0 C READ (KHANEL,'(A)',ERR=45,END=90) COMAND * GET EULER EQUIVALENT OF GIP ORIENTATION READ ( COMAND, '(33X, 3F14.8)', ERR=3 ) THETA, PHI, PSI IF ( DEBUGI ) THEN WRITE ( DUMMY, '('' GIPRD: RECOVERED EULER ANGLES: '', . 3F14.8)') THETA, PHI, PSI CALL DEBUGR( DUMMY( 1: 79) ) ENDIF 3 THETA= 0.01745329252D0*THETA PHI= 0.01745329252D0*PHI PSI= 0.01745329252D0*PSI SINTHE= SIN(THETA) COSTHE= COS(THETA) SINPHI= SIN(PHI) COSPHI= COS(PHI) SINPSI= SIN(PSI) COSPSI= COS(PSI) ROT11 = COSPHI*COSTHE*COSPSI-SINPHI*SINPSI ROT12 =SINPHI*COSTHE*COSPSI+COSPHI*SINPSI ROT13 =-SINTHE*COSPSI ROT21 =-COSPHI*COSTHE*SINPSI-SINPHI*COSPSI ROT22 =-SINPHI*COSTHE*SINPSI+COSPHI*COSPSI ROT23 = SINTHE*SINPSI ROT31 =COSPHI*SINTHE ROT32 =SINPHI*SINTHE ROT33 = COSTHE CALL ROTSUM( . ROT11,ROT12,ROT13,ROT21,ROT22,ROT23,ROT31,ROT32,ROT33 ) READ (KHANEL,'(A)',ERR=45,END=90) KEYWRD READ (KHANEL,'(A)',ERR=45,END=90) KOMENT READ (KHANEL,'(A)',ERR=45,END=90) TITLE DO 30 I=1,MAXATM READ (KHANEL,'(A)',ERR=45,END=90) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .EQ. ' ') THEN CALL DEBUGR('GIP INPUT FORMAT ERROR, NULL LINE') RETURN ENDIF 6 JJ=INDEX(COMAND,' ') NN(I)= NUMELE( COMAND( 1:JJ)) IF (NN(I) .EQ. 0 ) GO TO 100 CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ') THEN CALL DEBUGR( 'GIP INPUT FORMAT ERROR, X-COORD') RETURN ENDIF A(1,I) = READA( COMAND, 1,ERROR) CALL POPARG( COMAND, COMAND) INTFRE( 1, I) = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ') THEN CALL DEBUGR( 'GIP INPUT FORMAT ERROR, Y-COORD') RETURN ENDIF A(2,I) = READA( COMAND, 1,ERROR) CALL POPARG( COMAND, COMAND) INTFRE( 2, I) = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ') THEN CALL DEBUGR( 'GIP INPUT FORMAT ERROR, Z-COORD') RETURN ENDIF A(3,I) = READA( COMAND, 1,ERROR) CALL POPARG( COMAND, COMAND) INTFRE( 3, I) = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) C NOW FOR INTERNAL COORDINATE REFERENCES NA(I) = READA( COMAND, 1,ERROR) CALL POPARG( COMAND, COMAND) NB(I) = READA( COMAND, 1,ERROR) CALL POPARG( COMAND, COMAND) NC(I) = READA( COMAND, 1,ERROR) IF (DEBUGI) THEN CALL DEBUGR( COMAND(1:77) ) WRITE (DUMMY,3000) I,NN(I),(A(J,I),J=1,3),NA(I),NB(I),NC(I) CALL DEBUGR( DUMMY(1:77) ) ENDIF 3000 FORMAT (1X,I3,1X,I5,1X,3F10.5,3I5) 30 CONTINUE NATOMS=MAXATM WRITE (*,*) 'END NOT FOUND FOR INPUT GIP FILE.' CALL UPROMP( ' PRESS RETURN TO DRAW PICTURE...') READ (*,'(A)',END=101) COMAND GO TO 101 45 WRITE(*,'(''ERROR IN READING GIP FILE'')') IOERR=1 RETURN 90 IOERR=1 WRITE (*,*) 'GIPRD: END OF FILE.' RETURN C PROCESS CONNECTIVITY 100 NATOMS=I-1 NA(1) = 0 NB(1) = 0 NC(1) = 0 NA(2) = 1 NB(2) = 0 NC(2) = 0 101 DO 110 I=3,NATOMS 102 IF ( I .EQ. 3 ) THEN IF ( NA(I) .GT. I .OR. NA(I) .LT. 1 ) GOTO 105 IF ( NB(I) .GT. I .OR. NB(I) .LT. 1 ) GOTO 105 IF ( NC(I) .NE. 0 ) THEN WRITE (*,*) 'NC(3) IS NOT ZERO, WILL IGNORE' NC(I) = 0 ENDIF IF ( NA(I) .EQ. NB(I) ) GOTO 105 GOTO 110 ELSE IF ( NA(I) .GT. I .OR. NA(I) .LT. 1 ) GOTO 105 IF ( NB(I) .GT. I .OR. NB(I) .LT. 1 ) GOTO 105 IF ( NC(I) .GT. I .OR. NC(I) .LT. 1 ) GOTO 105 IF ( NA(I) .EQ. NB(I) ) GOTO 105 IF ( NB(I) .EQ. NC(I) ) GOTO 105 IF ( NA(I) .EQ. NC(I) ) GOTO 105 GOTO 110 ENDIF 105 DIST1=100. IKEEP = I-1 DO 200 IZZ=I-1,1,-1 DIST=SQRT( (A(1,I)-A(1,IZZ))**2 + (A(2,I)-A(2,IZZ))**2 + . (A(3,I)-A(3,IZZ))**2 ) IF (DIST.LT. DIST1 .AND. NN(IZZ).NE.1 ) THEN DIST1 = DIST IKEEP = IZZ ENDIF 200 CONTINUE I1=IKEEP I2=NA(IKEEP) IF ( I2 .LT. 1 ) THEN I1 = I -1 I2 = I -2 I3 = I - 3 ELSE I3=NB(IKEEP) IF ( I3 .LT. 1 ) THEN I1 = I -1 I2 = I -2 I3 = I - 3 ENDIF ENDIF WRITE (COMAND,1000) I,NN(I),NA(I),NB(I),NC(I),I1,I2,I3 1000 FORMAT (1X,I3,':',I2,4X,'IC error REFs NA=',I3,' NB=',I3, . ' NC=',I3,';enter new: [',3I5,'] ') CALL UPROMP( COMAND(:INDEX(COMAND, ']')+1 ) ) READ (*, '(A)') COMAND CALL LCLEAN(COMAND,COMAND, .TRUE.) NA(I)=I1 NB(I)=I2 NC(I)=I3 IEQ=INDEX(COMAND,'=') IF (IEQ.EQ.0 .AND. COMAND(:1).NE. ' ') THEN NA(I)=READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF IEQ=INDEX(COMAND,' ') 106 COMAND = COMAND(IEQ+1:) IEQ=INDEX(COMAND,' ') IF (IEQ.EQ.1) GOTO 106 NB(I)=READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF IEQ=INDEX(COMAND,' ') 107 COMAND = COMAND(IEQ+1:) IEQ=INDEX(COMAND,' ') IF (IEQ.EQ.1) GOTO 107 NC(I)=READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF IEQ=INDEX(COMAND,' ') 108 COMAND = COMAND(IEQ+1:) ELSE IEQ=INDEX(COMAND,'NA=') IF (IEQ .GT. 0) THEN NA(I)=READA(COMAND,IEQ+3,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF ENDIF IEQ=INDEX(COMAND,'NB=') IF (IEQ .GT. 0) THEN NB(I)=READA(COMAND,IEQ+3,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF ENDIF IEQ=INDEX(COMAND,'NC=') IF (IEQ .GT. 0) THEN NC(I)=READA(COMAND,IEQ+3,ERROR) IF (ERROR) THEN WRITE (*,*) 'READA ERROR' GOTO 105 ENDIF ENDIF ENDIF GOTO 102 110 CONTINUE RETURN END