C PROGRAM TEYFSF C C PROGRAM TO CONVERT A MAP IN TEN EYCK'S FFT FORMAT TO BC WANG'S FSFOR FORMAT C THE INPUT MAP *MUST* CORRESPOND TO THE CONSTRAINTS OF THE BC WANG FORMAT: C C (1) INPUT MAP MUST COVER ENTIRE UNIT CELL, NX, NY AND NZ GRID POINTS C ALONG X,Y AND Z. C (2) INPUT MAP MAY BE TERMINATED WITH A NEGATIVE SECTION NO. C C HEADER INFORMATION IS READ FROM A SEPARATE FILE, IN FSFOR FORMAT. C program asks for: name of input teneyck map C name of output fsfor map C max resolution of input map:this is written in the header C C NO. OF GRID POINTS IN ONE SECTION(i.e.(NACROSS)*(NDOWN)) C SHOULD NOT EXCEED MAPDIM.(currently 40000) C C NO. OF GRID POINTS ACROSS SHOULD NOT EXCEED MAPREC ( currently 200 ) C------------------------------------------------------------------------------ PARAMETER (MAPDIM=40000, MAPREC = 200) C DIMENSION AMAP(MAPDIM),MAP(MAPREC) CHARACTER*40 HEADER,MAPIN,MAPOUT CHARACTER*1 LATTYP(7) CHARACTER*1 LATT COMMON /IO/LC,LT,LH,LMAP,LTEYCK COMMON /OUTP/ITLE(20),NCENT,LATT,NSYM,NPIC,NOSET,LEVEL,IT4, $XLIM(3),PARA(6),TS(3,24),IS(2,3,24),SCALE,NXM,NYM,NZM,ASC, $NORN,IXSM,IYSM,IZSM,MNX(6) DIMENSION LINE1(80),WORDS(3) DATA WORDS /'XZ','YZ','XY'/ DATA NOSET,LEVEL,XLIM /2*0,3*0./ DATA LATTYP /'P','A','B','C','F','I','R'/ C--- DEFINE LOGICAL UNITS LC=5 LT=6 LTEYCK=10 LH = 1 LMAP=13 C------------------------- C WRITE (LT,20) READ (LC,90) HEADER OPEN (UNIT=LH,FILE=HEADER,STATUS='OLD',FORM='FORMATTED', . READONLY) WRITE (LT,25) READ (LC,90) MAPIN OPEN (UNIT=LTEYCK,FILE=MAPIN,STATUS='OLD',FORM='UNFORMATTED', . READONLY) WRITE (LT,30) READ (LC,90) MAPOUT OPEN(UNIT=LMAP,FILE = MAPOUT,FORM='UNFORMATTED', . ACCESS='SEQUENTIAL',BUFFERCOUNT=18,STATUS='NEW') C ACCEPT MAXIMUM RESOLUTION FROM USER: THIS HAS TO GO INTO HEADER WRITE (LT,35) READ (LC,*)RSPMX IF (RSPMX.EQ.0.0)RSPMX = 1.0 C C DEFINE SOME PARAMETERS FOR THE PACKED HEADER C MODE = 1 NBIT = 32 SCALE = 1.0 C C--- READ INPUT CONTROL DATA READ(LH,1)ITLE 1 FORMAT(20A4) READ(LH,2)LATT,NCENT,NSYM,NX,NY,NZ,MAPTYP,IT4,NPIC,NORN,GSP READ(LH,4)PARA 2 FORMAT(4X,A1,9I5,F5.2) 4 FORMAT(6F10.6) C--- DETERMINE NUMBER OF GRID POINTS ALONG EACH AXIS IF((NX*NY*NZ).EQ.0.)then write ( LT,1000) 1000 format (5x,' you MUST specify no. of grid points along each axis') go to 999 end if C WRITE(LT,1026) 1026 FORMAT(26X,'GENERAL EQUIVALENT POSITIONS',/) DO 1029 I=1,NSYM READ(LH,1030)LINE1 1030 FORMAT(80A1) K=I CALL TRANSL(K,LINE1,IS,TS,LT,1) CALL TRANSL(K,LINE1,IS,TS,LT,2) WRITE(LT,1032)LINE1 1032 FORMAT(15X,80A1) 1029 CONTINUE 1080 IF(NORN.LT.0.OR.NORN.GT.2)NORN=0 C--- C--- DETERMINE LATTICE TYPE C--- DO I = 1,7 IF (LATT.EQ.LATTYP(I))ICENT=I ENDDO IF (ICENT.EQ.0)THEN TYPE *, ' LATTICE TYPE READ INCORRECTLY FROM HEADER' GO TO 999 END IF C--- C--- OUTPUT HEADER INFORMATION TO MAP FILE C--- WRITE(LMAP)ITLE,NOSET,PARA,NSYM,NCENT,ICENT,NPIC DO 160 I=1,NSYM 160 WRITE(LMAP)(TS(J,I),(IS(K,J,I),K=1,2),J=1,3) C if (norn.eq.0)then ISEC = NY IA = NX ID = NZ WRITE(LMAP)NX,NZ,NY,SCALE,NORN,MNX,RSPMX,NBIT C else if (norn.eq.1)then ISEC = NX IA = NY ID = NZ WRITE(LMAP)NY,NZ,NX,SCALE,NORN,MNX,RSPMX,NBIT C else if (norn.eq.2)then ISEC = NZ IA = NX ID = NY WRITE(LMAP)NX,NY,NZ,SCALE,NORN,MNX,RSPMX,NBIT else type *, 'norn can only be 0, 1 or 2' GO TO 999 end if C--- ECHO INFORMATION TO LINE PRINTER WRITE(LT,1089)ISEC,WORDS(NORN+1),IA,ID 1089 FORMAT(//27X,'MAP WRITTEN AS ',I3,1X,A2,' SECTIONS', .//35X,'WITH',I3,' GRID POINTS ACROSS', .//35X,'AND ',I3,' GRID POINTS DOWN' ) C C READ TITLE OF TEN EYCK MAP READ(LTEYCK)JUNK C C READ TEN EYCK MAP ONE SECTION AT A TIME, C ... AND WRITE IT RECORD BY RECORD. C DO 130 II = 1,ISEC CALL READTEYCK ( IA,ID,AMAP,II,NERROR ) IF (NERROR.LT.0)GO TO 999 K = 0 DO 120 JJ = 1,ID DO 110 KK = 1,IA MAP(KK) = JIFIX(AMAP(KK+K)) 110 CONTINUE WRITE(LMAP)(MAP(I),I=1,IA) K = IA + K 120 CONTINUE 130 CONTINUE C___________________________________________________________________________ 20 FORMAT (T2,'Enter name of file with header info. ',T54,'> ',$) 25 FORMAT (T2,'Enter file name for input(Ten Eyck) map',T54,'> ',$) 30 FORMAT (T2,'Enter file name for the output map',T54,'> ',$) 35 FORMAT (T2,'Enter Max Resolution of input map',T54,'> ',$) 90 format (A) C------------------------------------------------------------------------------ 999 STOP END C----------------------------------------------------------------------------- SUBROUTINE TRANSL(J,LINE,IS,TS,LT,JUMP) DIMENSION LINE(80),ICH(14),IS(2,3,24),TS(3,24) DATA ICH/1H1,1H2,1H3,1H4,1H5,1H6,1HX,1HY,1HZ,1H ,1H,,1H+,1H-,1H// IF(JUMP.EQ.2) GO TO 980 IC=1 ISN=1 TRV=-1.0 IN=1 DO 90 I=1,81 IF(I.EQ.81) GO TO 40 DO 10 K=1,14 IF(LINE(I).EQ.ICH(K)) GO TO 30 10 CONTINUE WRITE(LT,20) LINE(I) 20 FORMAT(1H ,A1,24H IS AN INVALID CHARACTER) STOP 30 GO TO (80,80,80,80,80,80,70,70,70,90,40,90,50,90),K 40 IF(IN.EQ.2) IS(2,IC,J)=0 IF(TRV.LT.0.0) TS(IC,J)=0 IN=1 TRV=-1.0 IC=IC+1 GO TO 90 50 ISN=-1 GO TO 90 70 IS(IN,IC,J)=ISN*(K-6) ISN=1 IN=IN+1 GO TO 90 80 IF(TRV.LT.0.0) TRV=FLOAT(K) IF(TRV.GT.0.0) TS(IC,J)=TRV/FLOAT(K) 90 CONTINUE RETURN 980 DO 1000 I=1,80 LINE(I) = ICH(10) 1000 CONTINUE DO 1100 I=1,3 IND = 17 * I - 6 IF (IS(2,I,J) .EQ. 0) GO TO 1020 M = IABS(IS(2,I,J)) + 6 LINE(IND) = ICH(M) LINE(IND-2) = ICH(14) IF (IS(2,I,J) .LT. 0) LINE(IND-2) = ICH(13) IND = IND - 4 1020 M = IABS(IS(1,I,J)) + 6 LINE(IND) = ICH(M) IF (IS(1,I,J) .LT. 0) LINE(IND-2) = ICH(13) IF (TS(I,J) .EQ. 0.0) GO TO 1100 IF (IS(1,I,J) .GT. 0) LINE(IND-2) = ICH(12) TRV=TS(I,J) NUM=1 IF(TRV.GT.0.6) NUM=INT(TRV/(1.0-TRV)+0.1) NOM=INT(FLOAT(NUM)/TRV+0.1) LINE(IND-6)=ICH(NUM) LINE(IND-5)=ICH(14) LINE(IND-4)=ICH(NOM) 1100 CONTINUE RETURN END C------------------------------------------------------------------------------- SUBROUTINE READTEYCK ( IA,ID,AMAP,II,NERROR ) PARAMETER (MAPDIM = 40000) COMMON /IO/LC,LT,LH,LMAP,LTEYCK DIMENSION AMAP(MAPDIM) C NERROR = 0 C C READ SECTION HEADER C READ (LTEYCK)NSEC,NFASTI,NFASTF,NSLOWI,NSLOWF C C CHECK FOR END-OF-MAP C IF (NSEC.LT.0) THEN WRITE (LT,300)II 300 FORMAT(/5X, 'END OF TEN EYCK MAP REACHED AFTER',I4,' SECTIONS') NERROR = -2 GO TO 998 END IF C C MAKE SURE THAT IT TALLIES WITH INFO FROM FSFOR HEADER C NFAST = NFASTF - NFASTI + 1 NSLOW = NSLOWF - NSLOWI + 1 IF ( (NFAST.NE.IA).OR.(NSLOW.NE.ID) ) THEN WRITE (LT,400)IA,ID,NFAST,NSLOW 400 FORMAT(/5X,' INFORMATION ON FSFOR HEADER DOES NOT TALLY',/5X . ,'WITH SECTION HEADER ON TEN EYCK MAP.'//5X,' ACCORDING TO . FSFOR HEADER, YOU HAVE ',I4,' GRID POINTS ACROSS AND',I4,'GRID . POINTS DOWN',/5X,'BUT ON THE TEN EYCK MAP, YOU HAVE ',I4,' GRID . POINTS ACROSS AND ',I4,'GRID POINTS DOWN.') NERROR = -1 GO TO 998 END IF C C NOW READ SECTION NPNTS = IA*ID READ(LTEYCK)(AMAP(I),I=1,NPNTS) C 998 RETURN END