169 lines
6.2 KiB
Fortran
169 lines
6.2 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Subroutine to Measure Standard Refletions
|
|
C Modified to output to ITP for SICS MK
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE STDMES
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION ENREFB(10)
|
|
EQUIVALENCE (NREFB(1),ENREFB(1))
|
|
IF (NSTAN .EQ. 0) THEN
|
|
KQFLAG = 1
|
|
RETURN
|
|
ENDIF
|
|
CALL RSW (5,ILPT)
|
|
C-----------------------------------------------------------------------
|
|
C Set the standards flag
|
|
C-----------------------------------------------------------------------
|
|
100 ISTAN = 1
|
|
IF (ILPT .EQ. 0) THEN
|
|
IF (NMSEG .LE. NSEG) THEN
|
|
WRITE (COT,10000) IH,IK,IL,NREF,NSET,NMSEG,NBLOCK
|
|
ELSE
|
|
WRITE (COUT,10100) NSET,NREF,NBLOCK
|
|
ENDIF
|
|
CALL GWRITE(ITP,' ')
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Loop to measure NSTAN standards
|
|
C-----------------------------------------------------------------------
|
|
JH = IH
|
|
JK = IK
|
|
JL = IL
|
|
DO 120 NN = 1,NSTAN
|
|
IH = IHSTAN(NN)
|
|
IK = IKSTAN(NN)
|
|
IL = ILSTAN(NN)
|
|
C-----------------------------------------------------------------------
|
|
C Calculate angles, set the display, set the circles and measure
|
|
C-----------------------------------------------------------------------
|
|
IPRVAL = 0
|
|
CALL ANGCAL
|
|
CALL HKLN (IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),NREF)
|
|
110 IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN
|
|
CALL SAMMES (ITIME,ICC)
|
|
IF (ICC .EQ. 2) THEN
|
|
WRITE (COUT,12000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN)
|
|
CALL GWRITE(ITP,' ')
|
|
GO TO 120
|
|
ENDIF
|
|
ELSE
|
|
CALL MESINT (IROFL,ICC)
|
|
IF (ICC .GE. 4) GO TO 100
|
|
IF (ICC .EQ. 2) THEN
|
|
WRITE (COUT,12000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN)
|
|
CALL GWRITE(ITP,' ')
|
|
GO TO 120
|
|
ENDIF
|
|
IF (IROFL .NE. 0) GO TO 110
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Pack h&k and l&natt, put psi=999.0 to denote standard
|
|
C-----------------------------------------------------------------------
|
|
IHK(NB) = (IHSTAN(NN) + 500)*1000 + IKSTAN(NN) + 500
|
|
ILA(NB) = (ILSTAN(NN) + 500)*1000 + NATT
|
|
BCOUNT(NB) = COUNT
|
|
BBGR1(NB) = BGRD1
|
|
BBGR2(NB) = BGRD2
|
|
BTIME(NB) = PRESET
|
|
IF (IPRFLG .EQ. 0) THEN
|
|
IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN
|
|
BTIME(NB) = 10*ITIME + FRAC
|
|
ELSE
|
|
BTIME(NB) = FRAC
|
|
ENDIF
|
|
ENDIF
|
|
ENREFB(NB) = NREF
|
|
BPSI(NB) = 999.0
|
|
C-----------------------------------------------------------------------
|
|
C Write a block of intensity data to file
|
|
C-----------------------------------------------------------------------
|
|
IF (NB .GE. 10) THEN
|
|
WRITE (IID,REC=NBLOCK) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,
|
|
$ ENREFB,BPSI
|
|
NBLOCK = NBLOCK + 1
|
|
NB = 0
|
|
ENDIF
|
|
NB = NB+1
|
|
C-----------------------------------------------------------------------
|
|
C Sort out which attenuators to apply and write standard on terminal
|
|
C-----------------------------------------------------------------------
|
|
ATT = ATTEN(NATT+1)
|
|
IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN
|
|
IPCT = PRESET
|
|
IBCT = (PRESET - IPCT)*2000
|
|
PCOUNT = COUNT/IPCT - (BGRD1 + BGRD2)/IBCT
|
|
SIG = SQRT(COUNT/(IPCT*IPCT) + (BGRD1 + BGRD2)/(IBCT*IBCT))
|
|
PCOUNT = PCOUNT*ATT/IPCT
|
|
SIG = SIG*ATT/IPCT
|
|
PCT = IPCT
|
|
IF (ILPT .EQ. 0) THEN
|
|
WRITE (COUT,16000)
|
|
$ NN,IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),
|
|
$ THETA,PCT,NATT,BGRD1,COUNT,BGRD2,PCOUNT,SIG
|
|
CALL GWRITE(ITP,' ')
|
|
ENDIF
|
|
ELSE
|
|
PCOUNT = COUNT - (BGRD1 + BGRD2)/(2.0*FRAC)
|
|
PCOUNT = PCOUNT*ATT
|
|
IF (ILPT .EQ. 0) THEN
|
|
WRITE (COUT,13000)
|
|
$ NN,IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),
|
|
$ THETA,TIME,NATT,BGRD1,COUNT,BGRD2,PCOUNT
|
|
CALL GWRITE(ITP,' ')
|
|
ENDIF
|
|
SIG = SQRT(COUNT + (BGRD1 + BGRD2)/(4.0*FRAC*FRAC))
|
|
ICOUNT = COUNT + 0.5
|
|
ISIG = SIG + 0.5
|
|
IF (NATT .NE. 0) THEN
|
|
WRITE (COUT,14000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),NATT,
|
|
$ ICOUNT,ISIG,NN
|
|
ELSE
|
|
WRITE (COUT,14100) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),
|
|
$ ICOUNT,ISIG,NN
|
|
ENDIF
|
|
CALL GWRITE (ITP,' ')
|
|
IATT = NATT + 10
|
|
C-----------------------------------------------------------------------
|
|
C Write the profile on the screen
|
|
C-----------------------------------------------------------------------
|
|
CALL PROFIL
|
|
C-----------------------------------------------------------------------
|
|
C Test for K or Q stop
|
|
C-----------------------------------------------------------------------
|
|
ENDIF
|
|
CALL KORQ (KQFLAG)
|
|
IF (KQFLAG .EQ. 0) THEN
|
|
ISTAN = 0
|
|
KI = 'G3'
|
|
RETURN
|
|
ENDIF
|
|
KQFLGS = 1
|
|
IF (KQFLAG .EQ. 2) KQFLGS = 2
|
|
120 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Reset standards flag and return with a disguised call to GOLOOP
|
|
C-----------------------------------------------------------------------
|
|
ISTAN = 0
|
|
IH = JH
|
|
IK = JK
|
|
IL = JL
|
|
KI = 'G3'
|
|
IF(KQFLGS .NE. 0) THEN
|
|
KQFLAG = KQFLGS
|
|
ELSE
|
|
KQFLAG = 1
|
|
ENDIF
|
|
RETURN
|
|
10000 FORMAT (/20X,'Reference Reflection Measurement '/
|
|
$ ' Next reflection:',3I4,', # ',I4,', Set',I3,
|
|
$ ', Segment ',I2,', Record ',I4)
|
|
10100 FORMAT (/20X,'Reference Reflection Measurement at end of set',I3/
|
|
$ ' Restart at reflection #',I6,', segment 1, record',I5)
|
|
11000 FORMAT (3I4,' Setting Collision')
|
|
12000 FORMAT (3I4,' Scan Collision ')
|
|
13000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,10X,F7.0)
|
|
14000 FORMAT (3I4,I2,I7,'(',I4,')',I2)
|
|
14100 FORMAT (3I4,2X,I7,'(',I4,')',I2)
|
|
16000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,10X,2F8.2)
|
|
END
|