$DEBUG C-------------------------------------------------------------------------- C C EXTRACT - Program to extract distributed multipole information from C CADPAC (and SYSMO) results for use in the Buckingham-Fowler C electrostatic model C C This version extracts DMA's up to hexadecapole, but the C code as used in the quadrup., octup., and hexad. sections C is extensible to any order of multipole. The number of C multipole components expected in one line of printout is C also adjustable. C C The first line of source or its section should contain C the number of DMA centres in I4 format. It is assumed that C the first character of each output line is FORTRAN carriage C control (either 0 or 1) C C C Ver 06/93 ----- ZBIGNIEW KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, 02-668 Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C C C CADPAC lists DMA components with up to 6 per line, SYSMO with up C to 3 per line (printout was made to fit into 80 columns). There C are also differences in formatting of the coordinate line, and C SYSMO does not print out the 1/0 carriage control characters at C the beginning of each line. C C-------------------------------------------------------------------------- C CHARACTER*25 NAMIN,NAMOUT CHARACTER LINE*140,S3*4,ZERO*11,ORIGIN(2)*6,SOURCE*6 CHARACTER*3 DIPOLE(3),QUADRP(5),OCTUP(7),HEXAD(9) CHARACTER*11 OUTBUF(9) PARAMETER( S3='Site', 1 ZERO=' 0.000000') DATA DIPOLE/'10 ','11c','11s'/ DATA QUADRP/'20 ','21c','21s','22c','22s'/ DATA OCTUP/'30 ','31c','31s','32c','32s','33c','33s'/ DATA HEXAD/'40 ','41c','41s','42c','42s','43c','43s', 1 '44c','44s'/ DATA ORIGIN/'CADPAC','SYSMO'/ C WRITE(*,1) 1 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | EXTRACT - Extraction of DMA''s from CADPAC/SYSMO ', * 'output files',T79,'|'/ * ' |',76(1H_),'|'/' version 6/1993',T64,'Zbigniew KISIEL'//) 2 WRITE(*,3) 3 FORMAT(' Name of file containing the data: ',$) READ(*,'(A)',ERR=2)NAMIN OPEN(3,FILE=NAMIN,STATUS='OLD',ERR=2) C 4 WRITE(*,5) 5 FORMAT(' Name of file for output: ',$) READ(*,'(A)',ERR=4)NAMOUT OPEN(2,FILE=NAMOUT,STATUS='UNKNOWN',ERR=4) 7 WRITE(*,6) 6 FORMAT(1X//' Pray reveal wherefore cometh yer DMA (1=CADPAC, ', * '2=SYSMO): ',$) READ(*,'(I5)',ERR=7)ISORCE IF(ISORCE.NE.1.AND.ISORCE.NE.2)GOTO 7 SOURCE=ORIGIN(ISORCE) if(source.eq.'CADPAC')then npline=6 else npline=3 endif C C C Search through the data file C C...number of atoms C 1002 LABEL=1002 READ(3,'(I4)',ERR=10)NATOMS C WRITE(*,'(1X/1X,I5,'' ATOMS'')')NATOMS WRITE(2,'(1X/1X,I5,'' ATOMS'')')NATOMS C C C...Extract coordinates and multipoles for each atom in turn C 1100 LABEL=1100 DO 15 I=1,NATOMS LABEL=1100+I WRITE(*,'(/'' ATOM NO. '',I3)')I C C...coordinates C 16 READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')THEN LINE(1:139)=LINE(2:140) IF(LINE(1:4).NE.S3)GOTO 16 WRITE(*,17)LINE(26:35),LINE(41:50),LINE(56:65),LINE(8:21) WRITE(2,17)LINE(26:35),LINE(41:50),LINE(56:65),LINE(8:21) ELSE IF(LINE(1:4).NE.S3)GOTO 16 WRITE(*,17)LINE(22:31),LINE(37:46),LINE(52:61),LINE(9:17) WRITE(2,17)LINE(22:31),LINE(37:46),LINE(52:61),LINE(9:17) ENDIF 17 FORMAT(3(1X,A),A) C C...charge C READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) WRITE(*,18)LINE(26:36) WRITE(2,18)LINE(26:36) 18 FORMAT(1X,A) C C...dipole C READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) DO 20 N=1,3 OUTBUF(N)=ZERO 20 CONTINUE C NSTART=21 22 DO 23 N=1,3 IF(LINE(NSTART:NSTART+2).EQ.DIPOLE(N))THEN OUTBUF(N)=LINE(NSTART+5:NSTART+15) NSTART=NSTART+19 ENDIF 23 CONTINUE C WRITE(*,76)(OUTBUF(N),N=1,3) WRITE(2,26)(OUTBUF(N),N=1,3) C C...quadrupole C READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) DO 30 N=1,5 OUTBUF(N)=ZERO 30 CONTINUE NSTART=21 NINP=0 32 DO 33 N=1,5 IF(LINE(NSTART:NSTART+2).EQ.QUADRP(N))THEN OUTBUF(N)=LINE(NSTART+5:NSTART+15) NSTART=NSTART+19 NINP=NINP+1 IF(NINP.EQ.NPLINE*(NINP/NPLINE))THEN READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) IF((LINE(2:2).EQ.'Q').OR.(LINE(30:30).NE.'.'))THEN BACKSPACE(3) GOTO 35 ELSE NSTART=21 ENDIF ENDIF GOTO 32 ENDIF 33 CONTINUE C 35 WRITE(*,76)(OUTBUF(N),N=1,5) WRITE(2,26)(OUTBUF(N),N=1,5) 26 FORMAT(9(1X,A)) 76 FORMAT(1X,9A) C C...octupole C READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) DO 40 N=1,7 OUTBUF(N)=ZERO 40 CONTINUE NSTART=21 NINP=0 42 DO 43 N=1,7 IF(LINE(NSTART:NSTART+2).EQ.OCTUP(N))THEN OUTBUF(N)=LINE(NSTART+5:NSTART+15) NSTART=NSTART+19 NINP=NINP+1 IF(NINP.EQ.NPLINE*(NINP/NPLINE))THEN READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) IF((LINE(2:2).EQ.'Q').OR.(LINE(30:30).NE.'.'))THEN BACKSPACE(3) GOTO 45 ELSE NSTART=21 ENDIF ENDIF GOTO 42 ENDIF 43 CONTINUE C 45 WRITE(*,76)(OUTBUF(N),N=1,7) WRITE(2,26)(OUTBUF(N),N=1,7) C C...hexadecapole C READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) DO 50 N=1,9 50 OUTBUF(N)=ZERO NSTART=21 NINP=0 52 DO 53 N=1,9 IF(LINE(NSTART:NSTART+2).EQ.HEXAD(N))THEN OUTBUF(N)=LINE(NSTART+5:NSTART+15) NSTART=NSTART+19 NINP=NINP+1 IF(NINP.EQ.NPLINE*(NINP/NPLINE))THEN READ(3,'(A)',ERR=10)LINE IF(SOURCE.EQ.'CADPAC')LINE(1:139)=LINE(2:140) IF((LINE(2:2).EQ.'Q').OR.(LINE(30:30).NE.'.'))THEN BACKSPACE(3) GOTO 55 ELSE NSTART=21 ENDIF ENDIF GOTO 52 ENDIF 53 CONTINUE C 55 WRITE(*,76)(OUTBUF(N),N=1,9) WRITE(2,26)(OUTBUF(N),N=1,9) C 15 CONTINUE GOTO 9 C C...Error trapping C 10 WRITE(*,'('' INPUT ERROR after label '',I4,A1)')LABEL,CHAR(7) GOTO 9 11 WRITE(*,'('' STRING NOT FOUND after label '',I4,A1)')LABEL, 1 CHAR(7) C 9 CLOSE(2) CLOSE(3) C STOP END C C-------------------------------------------------------------------------- C--------------------------------------------------------------------------