PROGRAM TEST
INTEGER*2 IFLAG,INUNIT,OUTUNIT,IOPEN1,IOPEN7,IALL
DIMENSION APA(5)
CHARACTER*30 INFILE,OUTFILE
CHARACTER*1 ANS,TIYP
CALL GETCL(INFILE)
IALL=0
INUNIT=1
OUTUNIT=7
OPEN(UNIT=INUNIT,FILE=INFILE,FORM='UNFORMATTED',STATUS='OLD',
1 ACCESS='TRANSPARENT')
IOPEN1=1
PRINT*,'Screen only (S), or screen and file (F)? '
READ(*,1004)TIYP
IF(TIYP.EQ.'S'.OR.TIYP.EQ.'s')GO TO 7337
5 WRITE(*,1009)
1009 FORMAT(' OUTPUT FILE NAME? ',/)
READ(*,1004)OUTFILE
1004 FORMAT(A)
OPEN(UNIT=OUTUNIT,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
IOPEN7=1
7337 PRINT*,' Do you want the whole file? (y,n) '
READ(*,1004)ANS
IF(ANS.EQ.'y'.OR.ANS.EQ.'Y')IALL=1
IF(IALL.NE.1)PRINT*,'Hit Y to stop processing data'
CALL FIRSTPA(INUNIT,UT,APA,IFLAG)
IF(IFLAG.EQ.1)STOP
WRITE(*,1002)UT
1002 FORMAT(' First time in FPM file is ',F10.3,/)
UT=UT+.128
DO 135 JJ=1,10000
DO 134 I=1,20
UT=UT+10.
CALL GETPA(INUNIT,UT,APA,IFLAG)
IF(IFLAG.EQ.1)GOTO140
WRITE(*,19)UT,APA
19 FORMAT(1X,F10.3,2X,5f10.2)
IF(TIYP.EQ.'Y')WRITE(7,21)UT,APA
21 FORMAT(1X,F10.3,5(',',F10.2))
134 CONTINUE
IF(IALL.EQ.1)GO TO 135
READ(*,1004)ANS
IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GO TO 140
135 CONTINUE
140 IF(IOPEN1.EQ.1)CLOSE(INUNIT)
IF(IOPEN7.EQ.1)CLOSE(OUTUNIT)
STOP
END
C
SUBROUTINE GETPA(INUNIT,UT,APA,IFLAG)
DIMENSION ARRAY(4,33),DCS(3),BCMP(3),apa(5)
INTEGER*2 INDX,IFLAG,NDX,INUNIT
CHARACTER*1 ANS
DATA DCS/144.5,78.9,2.5/
1 NDX=INDX
DO 100 J=NDX,33
IF(UT.GT.ARRAY(1,J))GO TO 100
IF(ARRAY(1,J).GT.(UT+5000.))GO TO 88
TDEL=ARRAY(1,J)-ARRAY(1,J-1)
TPART1=(UT-ARRAY(1,J-1))/TDEL
BCMP(1)=TPART1*(ARRAY(2,J)-ARRAY(2,J-1))+ARRAY(2,J-1)
BCMP(2)=TPART1*(ARRAY(3,J)-ARRAY(3,J-1))+ARRAY(3,J-1)
BCMP(3)=TPART1*(ARRAY(4,J)-ARRAY(4,J-1))+ARRAY(4,J-1)
B=SQRT(DOT(BCMP,BCMP))
BMP=DOT(BCMP,DCS)/B
APA(1)=BCMP(1)
APA(2)=BCMP(2)
APA(3)=BCMP(3)
APA(4)=B
IF(BMP.GT.1.)BMP=1.
IF(BMP.LT.-1.)BMP=-1.
APAP=57.29572*ACOS(BMP)
IF(APAP.LT.0.)APAP=-APAP
IF(APAP.GT.180.)APAP=360.-APAP
APA(5)=APAP
RETURN
88 PRINT*,'Bad UT in .FPM: ',ARRAY(1,J)
100 INDX=INDX+1
DO 110 IJ=1,4
110 ARRAY(IJ,1)=ARRAY(IJ,33)
CALL GETSECT(INUNIT,ARRAY(1,2),IFLAG)
IF(IFLAG.EQ.1)THEN
PRINT*,' MAGNETIC FIELD FILE EXHAUSTED'
RETURN
ENDIF
INDX=2
GO TO 1
ENTRY FIRSTPA
CALL GETSECT(INUNIT,ARRAY(1,2),IFLAG)
IF(IFLAG.EQ.1)THEN
PRINT*,' MAGNETIC FIELD FILE CAN NOT BE READ'
RETURN
ENDIF
DO 120 IJ=1,4
120 ARRAY(IJ,1)=ARRAY(IJ,2)
INDX=2
UT=ARRAY(1,1)
PRINT*,'MEA (M) or custom (O) direction cosines? '
READ(*,200)ANS
200 FORMAT(A)
IF(ANS.EQ.'M'.OR.ANS.EQ.'m')GO TO 202
PRINT*,'X-axis cosine (degrees)? '
READ(*,201)DCS(1)
PRINT*,'Z-axis cosine (degrees)? '
201 FORMAT(F6.2)
READ(*,201)DCS(2)
PRINT*,'Y-axis cosine (degrees)? '
READ(*,201)DCS(3)
202 TMP3=COS(DCS(3)/57.29578)
TMP1=DCS(1)/57.29578
TMP2=DCS(2)/57.29578
DCS(1)=TMP3*COS(TMP1)
DCS(2)=-TMP3*COS(TMP2)
DCS(3)=TMP3*SIN(TMP1)*SIN(TMP2)
RETURN
END
SUBROUTINE GETSECT(INUNIT,BREC,IFLAG)
C A subroutine to read sectors from disk.
C IFLAG = 1 if reached end of file.
C TREC WILL CONTAIN ONE TAPE RECORD PLUS EOF
LOGICAL*1 BREC(512),TREC(32002)
INTEGER*2 INUNIT,IFLAG
INTEGER*4 NEW
IFLAG=0
IF(NEW.EQ.0)GO TO 1
GO TO 2
1 READ(UNIT=INUNIT,END=1000)TREC
NEW=0
2 IF(NEW.GT.31488)GO TO 1
DO 3 I=1,512
3 BREC(I)=TREC(NEW+I)
NEW=NEW+512
RETURN
1000 IFLAG=1
PRINT *,' END OF DATA ON INPUT FILE'
CLOSE (UNIT=INUNIT)
RETURN
END
SUBROUTINE SUFIX(NAME,SUF)
CHARACTER*1 NAME(51),SUF(3),SUF1
DATA SUF1/'.'/
DO 1 I=1,51
IF(NAME(I).EQ.'.')GOTO4
1 IF(NAME(I).EQ.' ')GOTO3
WRITE(*,2)NAME
2 FORMAT(' ***** ERROR ***** ERROR ***** ERROR *****',//,
1 A,//,' exceeds the limit on file names (50 characters)')
STOP
3 NAME(I)=SUF1
4 NAME(I+1)=SUF(1)
NAME(I+2)=SUF(2)
NAME(I+3)=SUF(3)
RETURN
END
FUNCTION DOT(A,B)
DIMENSION A(3),B(3)
DOT=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
RETURN
END