SUBROUTINE BSHEET C C Main steering routine for the BSHEET program C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSH.CIN' INCLUDE 'BSHIN.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COACOM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'COP.CIN' INCLUDE 'COPS.CIN' INCLUDE 'COSS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1B.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA1D.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'DATA2C.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'DATA2S.CIN' INCLUDE 'DATUM.CIN' INCLUDE 'DBEAM.CIN' INCLUDE 'DBEND.CIN' INCLUDE 'DCENT.CIN' INCLUDE 'DCORR.CIN' INCLUDE 'DCVTY.CIN' INCLUDE 'DDRFT.CIN' INCLUDE 'DETA.CIN' INCLUDE 'DFIT.CIN' INCLUDE 'DHKICK.CIN' INCLUDE 'DKICK.CIN' INCLUDE 'DMAGNE.CIN' INCLUDE 'DMIS.CIN' INCLUDE 'DOCT.CIN' INCLUDE 'DPLT.CIN' INCLUDE 'DQUAD.CIN' INCLUDE 'DRAN.CIN' INCLUDE 'DRBND.CIN' INCLUDE 'DROT.CIN' INCLUDE 'DSECT.CIN' INCLUDE 'DSEPM.CIN' INCLUDE 'DSEXT.CIN' INCLUDE 'DSHIFT.CIN' INCLUDE 'DSOLE.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'DSROT.CIN' INCLUDE 'DUNIT.CIN' INCLUDE 'DUPD.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1B.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM1F.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM5C.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM7D.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8C.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8I.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10C.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM10F.CIN' INCLUDE 'ELM11.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM24C.CIN' INCLUDE 'ELM24D.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38D.CIN' INCLUDE 'ELM38E.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'ELM39A.CIN' INCLUDE 'ELM39B.CIN' INCLUDE 'ELM39C.CIN' INCLUDE 'ELM39D.CIN' INCLUDE 'ELM41.CIN' INCLUDE 'ELM42.CIN' INCLUDE 'ELS0B.CIN' INCLUDE 'ELS1A.CIN' INCLUDE 'ELS1D.CIN' INCLUDE 'ELS7B.CIN' INCLUDE 'ELS8A.CIN' INCLUDE 'ELS8B.CIN' INCLUDE 'ELS8C.CIN' INCLUDE 'ELS13A.CIN' INCLUDE 'ELS16A.CIN' INCLUDE 'ELS16B.CIN' INCLUDE 'ELS20.CIN' INCLUDE 'ELS22A.CIN' INCLUDE 'ELS24A.CIN' INCLUDE 'ELS24B.CIN' INCLUDE 'ELS24C.CIN' INCLUDE 'ELS26B.CIN' INCLUDE 'ELS31.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'ETAPS.CIN' INCLUDE 'ETASC.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'FORDAT.CIN' INCLUDE 'FORCNT.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDFF.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IODATA.CIN' INCLUDE 'IOFLAG.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'KNAME.CIN' INCLUDE 'LBDAT.CIN' INCLUDE 'LIMITS.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'NBCELM.CIN' INCLUDE 'NDICT.CIN' INCLUDE 'NELMS.CIN' INCLUDE 'NPLIN.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'OCPS.CIN' INCLUDE 'OCS.CIN' INCLUDE 'OIV.CIN' INCLUDE 'PARDAT.CIN' INCLUDE 'PARLOC.CIN' INCLUDE 'PARVAL.CIN' INCLUDE 'R.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RCPS.CIN' INCLUDE 'RCS.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC2S.CIN' INCLUDE 'RC3.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R0PS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R2PS.CIN' INCLUDE 'R3P.CIN' INCLUDE 'RDBUFF.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'RDPRNT.CIN' INCLUDE 'RS.CIN' INCLUDE 'RSS.CIN' INCLUDE 'SI.CIN' INCLUDE 'SIS.CIN' INCLUDE 'STACK.CIN' INCLUDE 'SVP.CIN' INCLUDE 'UORIG.CIN' INCLUDE 'VARY.CIN' INCLUDE 'VFLAG.CIN' INCLUDE 'XORIG.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER NSAVE C C Declare the named Block Data as EXTERNAL so it loads properly C EXTERNAL BSHBLK C C------------------------------------------------------- RADIAN = 180.0/PI NV3 = NPVAR CALL RDINIT(NIN,NOUT) 1 CALL FITTINX CALL FINGER CALL REFCHK IF (ALIGN .OR. NUSE .NE. 0) CALL MARKCK C IF (ALIGN) THEN CALL MCOUNT CALL SPREAD CALL MIDENT CALL FINGER IF (NUSE .NE. 0) CALL MARKCK ENDIF C NSAVE = NV1 NV3 = 0 IBSH = 0 IF (ALIGN) CALL HARDEN NV3 = NSAVE CALL EXPLOR NV3 = 0 CALL OUTFITX IBSH = 1 NV1 = NSAVE IF (NV1 * NC .EQ. 0) GO TO 3 IF (.NOT. BEF) GO TO 2 CALL OUTFITX 2 NV3 = NSAVE CALL EXPLOR CALL SOLVE NV3 = NSAVE 3 CALL OUTFITX IBSH = 2 CALL OUTFITX IBSH = 3 CALL OUTFITX C GO TO 1 END BLOCK DATA BSHBLK C C BLOCKDATA FOR TRANSPORT AND BSHEET C C List of Commons C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DBEAM.CIN' INCLUDE 'DBEND.CIN' INCLUDE 'DCENT.CIN' INCLUDE 'DCVTY.CIN' INCLUDE 'DDRFT.CIN' INCLUDE 'DETA.CIN' INCLUDE 'DFIT.CIN' INCLUDE 'DHKICK.CIN' INCLUDE 'DKICK.CIN' INCLUDE 'DMAGNE.CIN' INCLUDE 'DMIS.CIN' INCLUDE 'DOCT.CIN' INCLUDE 'DPLT.CIN' INCLUDE 'DPRNT.CIN' INCLUDE 'DQUAD.CIN' INCLUDE 'DRAN.CIN' INCLUDE 'DRBND.CIN' INCLUDE 'DROT.CIN' INCLUDE 'DSHIFT.CIN' INCLUDE 'DSROT.CIN' INCLUDE 'DSECT.CIN' INCLUDE 'DSEPM.CIN' INCLUDE 'DSEXT.CIN' INCLUDE 'DSOLE.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'DUNIT.CIN' INCLUDE 'DUPD.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM39D.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDX.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'LIMITS.CIN' INCLUDE 'NELMS.CIN' INCLUDE 'NPLIN.CIN' INCLUDE 'NXRAN.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'SVALUE.CIN' INCLUDE 'UMAD.CIN' INCLUDE 'UMETER.CIN' INCLUDE 'UMICR.CIN' INCLUDE 'UMM.CIN' INCLUDE 'UTRANS.CIN' INCLUDE 'XMAD.CIN' INCLUDE 'XMETER.CIN' INCLUDE 'XMICR.CIN' INCLUDE 'XMM.CIN' INCLUDE 'XTRANS.CIN' C C------------------------------------------------------------ DATA INDX2 /0,1,3,6,10,15/ DATA INDX3 /0,1,4,10,20,35/ DATA NIN, NOUT, NPUNCH, NDATA, NPLOT /5, 6, 4, 7, 8/ DATA CT, CT0, CT1, VM /36*0.0,36*0.0,9*0.0,6*0.0/ DATA PI /3.14159265358979323/, CLIGHT /2.997924580E8/, 1 EMASS /.5110041E-3/ DATA ALM01 /0., 1., 0., 0./ DATA ALM02 /-1.04720,1., 1.04720,1./ DATA ALM03 /0., 1., 0., 0./ DATA ALM04 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0., 4 0., 0., 0., 0., 5 0., 0., 0., 0./ DATA ALM05 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0., 4 0., 0., 0., 0./ DATA ALM012 /-.99999, 1., .99999, 1., 1 -.99999, 1., .99999, 1., 2 -.99999, 1., .99999, 1., 3 -.99999, 1., .99999, 1., 4 -.99999, 1., .99999, 1., 5 -.99999, 1., .99999, 1., 6 -.99999, 1., .99999, 1., 7 -.99999, 1., .99999, 1., 8 -.99999, 1., .99999, 1., 9 -.99999, 1., .99999, 1., A -.99999, 1., .99999, 1., B -.99999, 1., .99999, 1., C -.99999, 1., .99999, 1., D -.99999, 1., .99999, 1., E -.99999, 1., .99999, 1./ DATA ALM018 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0./ DATA ALM019 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0./ DATA ALM020 /-360., 1., 360., 1./ DATA ALM025 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0./ DATA ALM028 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0., 4 0., 0., 0., 0., 5 0., 0., 0., 0., 6 0., 0., 0., 0., 7 0., 0., 0., 0., 8 0., 0., 0., 0., 9 0., 0., 0., 0., A 0., 0., 0., 0., B 0., 0., 0., 0., C 0., 0., 0., 0./ DATA ALM034 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0., 4 0., 0., 0., 0./ DATA ALM035 /0., 1., 0., 0., 1 0., 0., 0., 0., 2 0., 0., 0., 0., 3 0., 0., 0., 0./ DATA NELLIM /ISTLIM/, IDLIM /IDALIM/ END SUBROUTINE BPRINTX C C SUBROUTINE TO PRINT BEAM SHEET INFORMATION C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSH.CIN' INCLUDE 'BSHEEL.CIN' INCLUDE 'BSHIN.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'GRUMPF.CIN' INCLUDE 'ELNAM.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'JKLABC.CIN' INCLUDE 'JKLABS.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'NELN.CIN' INCLUDE 'OC.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'SHFTS.CIN' INCLUDE 'XYZOLD.CIN' C C LOCAL VARIABLES C CHARACTER*1 HYPHEN CHARACTER*2 AW2C CHARACTER*8 FRDNO, AW3C CHARACTER*10 LPRNT CHARACTER*10 AW2A, AW2B, AW3A CHARACTER*15 LABLL, ELNAME, AW3B CHARACTER*70 AW2D, AW3D1 CHARACTER*78 CMMN C INTEGER IALB, IALM, IALS, IAZD, IAZM, IAZS INTEGER IROD, IROM, IROS INTEGER ISLD, ISLM, ISLS INTEGER J, JFRD, JJ, JT, JU INTEGER K, KEND, KK, KLEN, KPK INTEGER M, N, NL, NN INTEGER NLAST REAL ALBEND, ALCEN, ALDEG, ALMIN, ALOLD, ALOLDS, ALPOS, ALPOSS REAL ALPRT, ALSEC, AZBS, AZCEN, AZOLD, AZPRT REAL AZMIN, AZSEC, AW2E1, AW2E2, AW2E3, AW2E4, AW2E5, AW2F REAL AW3D2, AW3D3, AW3E, AW3F, AW3G, AW3H, AW3I1A, AW3I1B, 1 AW3I1C REAL AW3I1D, AW3I1E, AW3I1F, AW3I1G, AW3I2A, AW3I2B, AW3I2C REAL AW3I2D, AW3I2E, AW3I2F, AW3I2G, AW3J1A, AW3J1B, AW3J1C REAL AW3J1D, AW3J1E, AW3J1F, AW3J1G, AW3J2A, AW3J2B, AW3J2C REAL AW3J2D, AW3J2E, AW3J2F, AW3J2G, AW3K1A, AW3K1B, AW3K2A REAL AW3K2B, AW4A1, AW4A2, AW4A3 REAL BLOB, COST, CS2, CSP, CSY REAL LEL, LCOLDF, LCPOSF, LCPRT REAL OTR(3,3), OLOC(3,3), OFOO(3,3), OCEN(3,3), OLCC(3,3), 1 OROT(3,3), OTEMP(3,3), OEND(3,3), OBEG(3,3), OTRO(3,3), 2 OLIC(3,3) REAL PICEN, PIOLD, PIPOS, PITCH, PITR, PITO, RHO, 1 ROCEN, ROCENC REAL ROLL, ROMIN, ROSEC, ROOLD, ROOLDC, ROPOSC REAL SHIFT, SINT, SNP, SNY, SLBS, SLCEN, SLMIN, SLOLD, SLSEC REAL SN2, TANO, TANP, TNSO, TNSP, TOTR REAL UFT, UDEG, REARTH REAL YAW, YAWR, YAWO REAL WORK1, XBEND, ZBEND REAL XBS, YBS, ZBS REAL XOLDS, YOLDS, ZOLDS REAL XPOSS, YPOSS, ZPOSS REAL XPRNT, YPRNT C EQUIVALENCE (CMMN, CMMNT(1)) C DATA HYPHEN /'-'/ DATA UFT /3.048E-1/, UDEG /.0174532925/ DATA REARTH /6.37032E6/ NAMELIST /AWN1/ AW2A, AW2B, AW2C, AW2D, AW2E1, AW2E2, AW2E3, 1 AW2E4, AW2E5, AW2F NAMELIST /AWN2/ AW3A, AW3B, AW3C, AW3D1, AW3D2, AW3D3, AW3E, 1 AW3F, AW3G, AW3H, 2 AW3I1A, AW3I1B, AW3I1C, AW3I1D, AW3I1E, AW3I1F, AW3I1G, 3 AW3I2A, AW3I2B, AW3I2C, AW3I2D, AW3I2E, AW3I2F, AW3I2G, 4 AW3J1A, AW3J1B, AW3J1C, AW3J1D, AW3J1E, AW3J1F, AW3J1G, 5 AW3J2A, AW3J2B, AW3J2C, AW3J2D, AW3J2E, AW3J2F, AW3J2G, 6 AW3K1A, AW3K1B, AW3K2A, AW3K2B NAMELIST /AWN3/ AW4A1, AW4A2, AW4A3 C C QUANTITIES FOR "AW" FILE C IF (TYPE .EQ. 1 .AND. IBSH .EQ. 3) THEN WRITE (AW2A,'(A10)') GRUMPF AW2B = ' 86/11/25 ' AW2C = LABEAM AW2D = IMAGE AW2E1 = XPIN AW2E2 = YPIN AW2E3 = ZPIN AW2E4 = THPIN IF (AW2E4 .LT. 0.0) AW2E4 = AW2E4 + 360.0 AW2E5 = PHPIN AW2F = LC WRITE (7,AWN1) ENDIF C C RESTRICTION TO BEAM ELEMENT OR PHYSICAL ELEMENTS C IF (TYPE .NE. 1 .AND. TYPE .NE. 2 .AND. TYPE .NE. 3 1 .AND. TYPE .NE. 4 .AND. TYPE .NE. 5 .AND. TYPE .NE. 11 2 .AND. TYPE .NE. 18 .AND. TYPE .NE. 19 .AND. TYPE .NE. 20 3 .AND. TYPE .NE. 25 .AND. TYPE .NE. 28 .AND. TYPE .NE. 29 4 .AND. TYPE .NE. 35 .AND. TYPE .NE. 36 .AND. TYPE .NE. 41) 5 GO TO 5200 C C RESTRICT CONSIDERATION TO PHYSICAL ELEMENTS C IF (TYPE .EQ. 1) GO TO 5200 C C TRANSFORMATION AT BEGINNING AND END OF ELEMENT C DO 28 J = 1, 3 DO 28 K = 1, 3 OEND(J,K) = O(4,J,K) 28 CONTINUE C DO 30 J = 1, 3 DO 30 K = 1, 3 OBEG(J,K) = OOLD(J,K) 30 CONTINUE C CALL SURVEYX C C LOOK FOR TILT OR REFER C IF ((REFER .OR. TILT) .AND. TOTRC .NE. 0.0) THEN TOTR = TOTRC IF (.NOT. REFER) TOTR = TOTR - TOTROT COST = COS(TOTR) SINT = SIN(TOTR) OROT(1,1) = COST OROT(1,2) = SINT OROT(1,3) = 0.0 OROT(2,1) = - SINT OROT(2,2) = COST OROT(2,3) = 0.0 OROT(3,1) = 0.0 OROT(3,2) = 0.0 OROT(3,3) = 1.0 C DO 35 J = 1, 3 DO 35 K = 1, 3 BLOB = 0.0 DO 34 M = 1, 3 BLOB = BLOB + OROT(J,M)*OEND(M,K) 34 CONTINUE OTEMP(J,K) = BLOB 35 CONTINUE C DO 40 J = 1, 3 DO 40 K = 1, 3 OEND(J,K) = OTEMP(J,K) 40 CONTINUE C DO 45 J = 1, 3 DO 45 K = 1, 3 BLOB = 0.0 DO 43 M = 1, 3 BLOB = BLOB + OROT(J,M)*OBEG(M,K) 43 CONTINUE OTEMP(J,K) = BLOB 45 CONTINUE C DO 50 J = 1, 3 DO 50 K = 1, 3 OBEG(J,K) = OTEMP(J,K) 50 CONTINUE ENDIF C C TRANSFORMATION TO LOCALLY LEVEL COORDINATE SYSTEM AT C BEGINNING OF ELEMENT C IF (ZOLD .EQ. ZPIN) THEN YAWO = 0.0 ELSE YAWO = ATAN((XOLD - XPIN)/(ZOLD - ZPIN)) ENDIF PITO = ATAN(SQRT((XOLD - XPIN)**2 + (ZOLD - ZPIN)**2)/REARTH) CSY = COS(YAWO) SNY = SIN(YAWO) CSP = COS(PITO) SNP = SIN(PITO) OTRO(1,1) = CSY**2 + SNY**2*CSP OTRO(1,2) = SNY*SNP OTRO(1,3) = SNY*CSY*(CSP - 1.0) OTRO(2,1) = - SNY*SNP OTRO(2,2) = CSP OTRO(2,3) = - CSY*SNP OTRO(3,1) = SNY*CSY*(CSP - 1.0) OTRO(3,2) = CSY*SNP OTRO(3,3) = SNY**2 + CSY**2*CSP C DO 60 J = 1, 3 DO 60 K = 1, 3 BLOB = 0.0 DO 58 M = 1, 3 BLOB = BLOB + OBEG(J,M)*OTRO(M,K) 58 CONTINUE OLIC(J,K) = BLOB 60 CONTINUE C C TRANSFORMATION TO LOCALLY LEVEL COORDINATE SYSTEM AT END OF C ELEMENT C IF (ZPOS .EQ. ZPIN) THEN YAWR = 0.0 ELSE YAWR = ATAN((XPOS - XPIN)/(ZPOS - ZPIN)) ENDIF PITR = ATAN(SQRT((XPOS - XPIN)**2 + (ZPOS - ZPIN)**2)/REARTH) CSY = COS(YAWR) SNY = SIN(YAWR) CSP = COS(PITR) SNP = SIN(PITR) OTR(1,1) = CSY**2 + SNY**2*CSP OTR(1,2) = SNY*SNP OTR(1,3) = SNY*CSY*(CSP - 1.0) OTR(2,1) = - SNY*SNP OTR(2,2) = CSP OTR(2,3) = - CSY*SNP OTR(3,1) = SNY*CSY*(CSP - 1.0) OTR(3,2) = CSY*SNP OTR(3,3) = SNY**2 + CSY**2*CSP C DO 65 J = 1, 3 DO 65 K = 1, 3 BLOB = 0.0 DO 63 M = 1, 3 BLOB = BLOB + OEND(J,M)*OTR(M,K) 63 CONTINUE OLOC(J,K) = BLOB 65 CONTINUE C C DETERMINE ELEMENT ORIENTATION C IF BENDING MAGNET, TILT BY HALF OF BEND ANGLE C IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 28 1 .OR. TYPE .EQ. 29) THEN CS2 = COS(0.5*AL) SN2 = SIN(0.5*AL) OFOO(1,1) = CS2 OFOO(1,2) = 0.0 OFOO(1,3) = - SN2 OFOO(2,1) = 0.0 OFOO(2,2) = 1.0 OFOO(2,3) = 0.0 OFOO(3,1) = SN2 OFOO(3,2) = 0.0 OFOO(3,3) = CS2 C DO 80 J = 1, 3 DO 80 K = 1, 3 BLOB = 0.0 DO 78 M = 1, 3 BLOB = BLOB + OFOO(J,M)*OEND(M,K) 78 CONTINUE OTEMP(J,K) = BLOB 80 CONTINUE C DO 85 J = 1, 3 DO 85 K = 1, 3 OCEN(J,K) = OTEMP(J,K) 85 CONTINUE ELSE DO 90 J = 1, 3 DO 90 K = 1, 3 OCEN(J,K) = OEND(J,K) 90 CONTINUE ENDIF C DO 100 J = 1, 3 DO 100 K = 1, 3 BLOB = 0.0 DO 95 M = 1, 3 BLOB = BLOB + OCEN(J,M)*OTR(M,K) 95 CONTINUE OLCC(J,K) = BLOB 100 CONTINUE C ALOLD = YOLD 1 + ((XOLD - XPIN)**2 + (ZOLD - ZPIN)**2)/(2.0*REARTH) YAW = ATAN(OBEG(3,1)/OBEG(3,3)) IF (OBEG(3,3) .GE. 0.0) GO TO 111 SHIFT = SIGN(PI,OBEG(3,1)) YAW = YAW + SHIFT 111 AZOLD = YAW/UDEG IF (AZOLD .LT. 0.0) AZOLD = AZOLD + 360.0 YAW = YAW/UNITO(7) C PITCH = ASIN(OBEG(3,2)) PIOLD = PITCH/UDEG PITCH = ASIN(OLIC(3,2)) SLOLD = PITCH/UDEG C IF (OBEG(2,2) .NE. 0.0) ROLL = ATAN(OBEG(1,2)/OBEG(2,2)) IF (OBEG(2,2) .EQ. 0.0 .AND. OBEG(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OBEG(2,2) .EQ. 0.0 .AND. OBEG(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OBEG(2,2) .GE. 0.0) GO TO 112 SHIFT = SIGN(PI,OBEG(1,2)) ROLL = ROLL + SHIFT 112 ROOLD = ROLL/UDEG C C ORIENTATION OF EXIT OF MAGNET C ALPOS = YPOS 1 + ((XPOS - XPIN)**2 + (ZPOS - ZPIN)**2)/(2.0*REARTH) YAW = ATAN(OEND(3,1)/OEND(3,3)) IF (OEND(3,3) .GE. 0.0) GO TO 121 SHIFT = SIGN(PI,OEND(3,1)) YAW = YAW + SHIFT 121 AZPOS = YAW/UDEG IF (AZPOS .LT. 0.0) AZPOS = AZPOS + 360.0 YAW = YAW/UNITO(7) C PITCH = ASIN(OEND(3,2)) PIPOS = PITCH/UDEG PITCH = ASIN(OLOC(3,2)) SLPOS = PITCH/UDEG C IF (OEND(2,2) .NE. 0.0) ROLL = ATAN(OEND(1,2)/OEND(2,2)) IF (OEND(2,2) .EQ. 0.0 .AND. OEND(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OEND(2,2) .EQ. 0.0 .AND. OEND(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OEND(2,2) .GE. 0.0) GO TO 122 SHIFT = SIGN(PI,OEND(1,2)) ROLL = ROLL + SHIFT 122 ROPOS = ROLL/UDEG C C SET OLD POSITIONS AND ANGLES TO CURRENT POSITIONS AND ANGLES C XCENT = 0.5*(XOLD + XPOS) YCENT = 0.5*(YOLD + YPOS) ZCENT = 0.5*(ZOLD + ZPOS) CALL POSTEX WORK1 = LC/UNITO(8) IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 28 1 .OR. TYPE .EQ. 29 .OR. TYPE .EQ. 35 .OR. TYPE .EQ. 36 2 .OR. TYPE .EQ. 42) THEN LEL = LBEND ELSE LEL = L ENDIF C DO 123 J = 1, 3 123 SHFTS(J) = 0.0 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 28 1 .OR. TYPE .EQ. 29) THEN IF (H0 .NE. 0.0) THEN RHO = 1.0/H0 SN2 = SIN(0.5*AL) CS2 = COS(0.5*AL) SHIFT = 0.25*LEL*SN2/(1.0 + CS2) SHFTS(1) = SHIFT*OCEN(1,1) SHFTS(2) = SHIFT*OCEN(1,2) SHFTS(3) = SHIFT*OCEN(1,3) XCENT = XCENT + SHFTS(1) YCENT = YCENT + SHFTS(2) ZCENT = ZCENT + SHFTS(3) ENDIF ENDIF C C ORIENTATION WITH RESPECT TO CURVED EARTH OF ENTRANCE OF MAGNET C IF (OLIC(2,2) .NE. 0.0) ROLL = ATAN(OLIC(1,2)/OLIC(2,2)) IF (OLIC(2,2) .EQ. 0.0 .AND. OLIC(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OLIC(2,2) .EQ. 0.0 .AND. OLIC(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OLIC(2,2) .GE. 0.0) GO TO 125 SHIFT = SIGN(PI,OLIC(1,2)) ROLL = ROLL + SHIFT 125 ROOLDC = ROLL/UDEG C ALCEN = YCENT 1 + ((XCENT - XPIN)**2 + (ZCENT - ZPIN)**2)/(2.0*REARTH) C C ORIENTATION WITH RESPECT TO CURVED EARTH OF EXIT OF MAGNET C IF (OLOC(2,2) .NE. 0.0) ROLL = ATAN(OLOC(1,2)/OLOC(2,2)) IF (OLOC(2,2) .EQ. 0.0 .AND. OLOC(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OLOC(2,2) .EQ. 0.0 .AND. OLOC(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OLOC(2,2) .GE. 0.0) GO TO 130 SHIFT = SIGN(PI,OLOC(1,2)) ROLL = ROLL + SHIFT 130 ROPOSC = ROLL/UDEG ROLL = ROLL/UNITO(7) C ALCEN = YCENT 1 + ((XCENT - XPIN)**2 + (ZCENT - ZPIN)**2)/(2.0*REARTH) YAW = ATAN(OCEN(3,1)/OCEN(3,3)) IF (OCEN(3,3) .GE. 0.0) GO TO 141 SHIFT = SIGN(PI,OCEN(3,1)) YAW = YAW + SHIFT 141 AZCEN = YAW/UDEG IF (AZCEN .LT. 0.0) AZCEN = AZCEN + 360.0 YAW = YAW/UNITO(7) C PITCH = ASIN(OCEN(3,2)) PICEN = PITCH/UDEG PITCH = ASIN(OLCC(3,2)) SLCEN = PITCH/UDEG PITCH = PITCH/UNITO(7) C C ORIENTATION OF CENTER OF MAGNET C IF (OCEN(2,2) .NE. 0.0) ROLL = ATAN(OCEN(1,2)/OCEN(2,2)) IF (OCEN(2,2) .EQ. 0.0 .AND. OCEN(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OCEN(2,2) .EQ. 0.0 .AND. OCEN(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OCEN(2,2) .GE. 0.0) GO TO 142 SHIFT = SIGN(PI,OCEN(1,2)) ROLL = ROLL + SHIFT 142 ROCEN = ROLL/UDEG IF (OLCC(2,2) .NE. 0.0) ROLL = ATAN(OLCC(1,2)/OLCC(2,2)) IF (OLCC(2,2) .EQ. 0.0 .AND. OLCC(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OLCC(2,2) .EQ. 0.0 .AND. OLCC(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OLCC(2,2) .GE. 0.0) GO TO 143 SHIFT = SIGN(PI,OLCC(1,2)) ROLL = ROLL + SHIFT 143 ROCENC = ROLL/UDEG ROLL = ROLL/UNITO(7) C C CREATE PRINTED LABEL FROM BEAM NAME AND ELEMENT LABEL C IF SEVERAL ELEMENTS HAVE THE SAME LABEL ADD A COUNTER C IF (TYPE .EQ. 2) THEN LABLL = LABEL(NUM-1) ELSE LABLL = LABEL(NUM) ENDIF IF (LABLL .EQ. BLANK) GO TO 5200 IF (LABEAM(1:1) .EQ. LABLL(1:1)) THEN LPRNT = LABLL(1:10) ELSE LPRNT(1:2) = LABEAM LPRNT(3:10) = LABLL(1:8) ENDIF IF (TYPE .EQ. 3) GO TO 200 DO 145 N = 1, NLABS NN = N IF (LLIST(N) .EQ. LPRNT) GO TO 150 145 CONTINUE GO TO 200 150 IF (KLAB(NN) .LE. 1) GO TO 200 NLAST = 0 DO 153 J = 1, 8 IF (LPRNT(J:J) .NE. BLANK) NLAST = J 153 CONTINUE NL = NLAST + 1 LPRNT(NL:NL) = HYPHEN NL = NLAST + 2 JLAB(NN) = JLAB(NN) + 1 JU = MOD(JLAB(NN),10) IF (JLAB(NN) .GE. 10) THEN JT = JLAB(NN)/10 LPRNT(NL:NL) = TABLE(JT+1) NL = NL + 1 ENDIF LPRNT(NL:NL) = TABLE(JU+1) IF (JLAB(NN) .EQ. 1) THEN XBS = XOLD ZBS = ZOLD YBS = YOLD AZBS = AZOLD SLBS = SLOLD ENDIF C C EXTRACT IDENTIFICATION OF MAGNET TYPE FROM PRECEDING COMMENT C 200 IF (TYPE .EQ. 2) THEN ELNAME = KELEM(4) ELSE ELNAME = KELEM(TYPE) ENDIF IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) ELNAME = KELEM(4) DO 280 J = 1, NELN JJ = J IF (ELNAM(J) .EQ. BLANK) GO TO 280 DO 260 K = 1, 15 KK = 16 - K IF (ELNAM(J)(KK:KK) .EQ. BLANK) GO TO 260 KLEN = KK GO TO 265 260 CONTINUE 265 KEND = 79 - KLEN DO 270 K = 1, KEND KPK = K + KLEN - 1 IF (CMMN(K:KPK) .EQ. ELNAM(JJ)(1:KLEN)) GO TO 290 270 CONTINUE 280 CONTINUE GO TO 5000 290 ELNAME = ELNAM(JJ) C C EXPRESS QUANTITIES IN FEET AND DEGREES C 5000 XCENT = XCENT/UFT YCENT = YCENT/UFT ZCENT = ZCENT/UFT LCPOSF = LCPOS/UFT LCOLDF = LCOLD/UFT XPOS = XPOS/UFT YPOS = YPOS/UFT ZPOS = ZPOS/UFT ALPOS = ALPOS/UFT XOLD = XOLD/UFT YOLD = YOLD/UFT ZOLD = ZOLD/UFT ALOLD = ALOLD/UFT C C PRINT BEAM SHEET C IF (IBSH .EQ. 1) GO TO 5050 IF (IBSH .EQ. 2) GO TO 5100 IF (IBSH .EQ. 3) GO TO 5150 C C MAKE LIST OF POSSIBLE LABELS C IF (TYPE .EQ. 3) GO TO 5200 IF (NLABS .EQ. 0) GO TO 5020 DO 5010 N = 1, NLABS NN = N IF (LABEL(NUM) .EQ. LLIST(N)) GO TO 5030 5010 CONTINUE 5020 NLABS = NLABS + 1 NN = NLABS LLIST(NN) = LABEL(NUM) 5030 KLAB(NN) = KLAB(NN) + 1 GO TO 5200 C C FIRST BEAM SHEET C 5050 IF (TYPE .NE. 3) GO TO 5080 IF (VBEND) GO TO 5075 WRITE (NOUT,9050) ZCENT, XCENT, LPRNT, 1 (CMMNT(J), J = 1, 40) GO TO 5200 5075 WRITE (NOUT,9051) ZCENT, XCENT, YCENT, LPRNT, 1 (CMMNT(J), J = 1, 40) 9051 FORMAT (1H ,3F10.2,4X,A10,2X,40A1,4X,F10.3) GO TO 5200 C 5080 IF (VBEND) GO TO 5085 WRITE (NOUT,9050) ZCENT, XCENT, LPRNT, 1 (CMMNT(J), J = 1, 40), B 9050 FORMAT (1H ,2F10.2,4X,A10,2X,40A1,4X,F10.3) GO TO 5200 5085 WRITE (NOUT,9051) ZCENT, XCENT, YCENT, LPRNT, 1 (CMMNT(J), J = 1, 40), B GO TO 5200 C C SECOND BEAM SHEET C 5100 IF (LEL .EQ. 0) GO TO 5120 WRITE (NOUT,9052) LPRNT, ELNAME, LCOLDF 5120 WRITE (NOUT,9052) LPRNT, ELNAME, LCPOSF 9052 FORMAT (1H ,A10,4X,A8,4X,F10.1) GO TO 5200 C C THIRD BEAM SHEET C EXTRACTION OF FRD NUMBER C 5150 FRDNO = BLANK DO 5151 J = 1, 33 JFRD = J IF (CMMN(J:J+2) .EQ. 'FRD') GO TO 5155 5151 CONTINUE GO TO 5160 5155 FRDNO(1:5) = CMMN(JFRD+3:JFRD+7) C C UPSTREAM FLOOR COORDINATES C 5160 IF (LEL .EQ. 0) GO TO 5170 LCPRT = 12.0*LCOLDF XPRNT = - 12.0*XOLD YPRNT = 12.0*ZOLD ALPRT = 12.0*ALOLD AZPRT = 360.0 - AZOLD IAZD = INT(AZPRT) AZMIN = 60.0*(AZPRT - FLOAT(IAZD)) IAZM = INT(AZMIN) AZSEC = 60.0*(AZMIN - FLOAT(IAZM)) IAZS = INT(AZSEC + 0.5) ISLD = INT(ABS(SLOLD)) SLMIN = 60.0*(ABS(SLOLD) - FLOAT(ISLD)) ISLM = INT(SLMIN) SLSEC = 60.0*(SLMIN - FLOAT(ISLM)) ISLS = INT(SLSEC + 0.5) IF (SLOLD .LT. 0) ISLD = - ISLD IF (SLOLD .LT. 0 .AND. ISLD .EQ. 0) ISLM = - ISLM IF (SLOLD .LT. 0 .AND. ISLD .EQ. 0 .AND. ISLM .EQ. 0) 1 ISLS = - ISLS IROD = INT(ABS(ROOLD)) ROMIN = 60.0*(ABS(ROOLD) - FLOAT(IROD)) IROM = INT(ROMIN) ROSEC = 60.0*(ROMIN - FLOAT(IROM)) IROS = INT(ROSEC + 0.5) IF (ROOLD .LT. 0) IROD = - IROD IF (ROOLD .LT. 0 .AND. IROD .EQ. 0) IROM = - IROM IF (ROOLD .LT. 0 .AND. IROD .EQ. 0 .AND. IROM .EQ. 0) 1 IROS = - IROS WRITE (NOUT,9053) LPRNT, ELNAME, FRDNO, LCPRT, 1 XPRNT, YPRNT, ALPRT, IAZD, IAZM, IAZS, 2 ISLD, ISLM, ISLS, IROD, IROM, IROS 9053 FORMAT (1H ,A10,4X,A12,2X,A8,2X,F12.3,2X,F12.3,2X,F12.3,2X, 1 F12.3,2X,I4,I3,I3,2X,I4,I3,I3,2X,I4,I3,I3) IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 28 1 .OR. TYPE .EQ. 29) THEN XPRNT = - 12.0*(XOLD + SHFTS(1)) YPRNT = 12.0*(ZOLD + SHFTS(3)) ALPRT = 12.0*(ALOLD + SHFTS(2)) WRITE (NOUT,9054) XPRNT, YPRNT, ALPRT 9054 FORMAT (1H ,18X,'SAGITTA CORRECTED',17X,F12.3,2X,F12.3,2X,F12.3) ENDIF C C DOWNSTREAM FLOOR COORDINATES C 5170 LCPRT = 12.0*LCPOSF XPOSS = XPOS + SHFTS(1) YPOSS = YPOS + SHFTS(2) ZPOSS = ZPOS + SHFTS(3) ALPOSS = ALPOS + SHFTS(2) XOLDS = XOLD + SHFTS(1) YOLDS = YOLD + SHFTS(2) ZOLDS = ZOLD + SHFTS(3) ALOLDS = ALOLD + SHFTS(2) XPRNT = - 12.0*XPOS YPRNT = 12.0*ZPOS ALPRT = 12.0*ALPOS AZPRT = 360.0 - AZPOS IAZD = INT(AZPRT) AZMIN = 60.0*(AZPRT - FLOAT(IAZD)) IAZM = INT(AZMIN) AZSEC = 60.0*(AZMIN - FLOAT(IAZM)) IAZS = INT(AZSEC + 0.5) C ISLD = INT(ABS(SLPOS)) SLMIN = 60.0*(ABS(SLPOS) - FLOAT(ISLD)) ISLM = INT(SLMIN) SLSEC = 60.0*(SLMIN - FLOAT(ISLM)) ISLS = INT(SLSEC + 0.5) IF (SLPOS .LT. 0.0) ISLD = - ISLD IF (SLPOS .LT. 0.0 .AND. ISLD .EQ. 0) ISLM = - ISLM IF (SLPOS .LT. 0.0 .AND. ISLD .EQ. 0 .AND. ISLM .EQ. 0) 1 ISLS = - ISLS C IROD = INT(ABS(ROPOS)) ROMIN = 60.0*(ABS(ROPOS) - FLOAT(IROD)) IROM = INT(ROMIN) ROSEC = 60.0*(ROMIN - FLOAT(IROM)) IROS = INT(ROSEC + 0.5) IF (ROPOS .LT. 0.0) IROD = - IROD IF (ROPOS .LT. 0.0 .AND. IROD .EQ. 0) IROM = - IROM IF (ROPOS .LT. 0.0 .AND. IROD .EQ. 0 .AND. IROM .EQ. 0) 1 IROS = - IROS WRITE (NOUT,9053) LPRNT, ELNAME, FRDNO, LCPRT, 1 XPRNT, YPRNT, ALPRT, IAZD, IAZM, IAZS, 2 ISLD, ISLM, ISLS, IROD, IROM, IROS ALDEG = 0.0 IF (TYPE .NE. 2 .AND. TYPE .NE. 4 .AND. TYPE .NE. 28 1 .AND. TYPE .NE. 29) GO TO 5180 XPRNT = - 12.0*XPOSS YPRNT = 12.0*ZPOSS ALPRT = 12.0*ALPOSS WRITE (NOUT,9054) XPRNT, YPRNT, ALPRT ALDEG = AL/UDEG C C BEND POINT OF SINGLE BENDING MAGNET C TANO = TAN(PI*AZOLD/180.0) TANP = TAN(PI*AZPOS/180.0) TNSO = TAN(PI*SLOLD/180.0) TNSP = TAN(PI*SLPOS/180.0) IF (TANO .EQ. TANP .AND. OBEG(3,2) .EQ. OEND(3,2)) GO TO 5175 IF (TANO .NE. TANP) THEN ZBEND = (XPOS - XOLD + ZOLD*TANO - ZPOS*TANP)/(TANO - TANP) ELSE ZBEND = (YPOS - YOLD + ZOLD*TNSO - ZPOS*TNSP)/(TNSO - TNSP) ENDIF XBEND = XOLD + TANO*(ZBEND - ZOLD) XPRNT = -12.0*XBEND YPRNT = 12.0*ZBEND ALBEND = AZOLD - AZPOS IF (ALBEND .LT. 0.0) ALBEND = ALBEND + 360.0 IALB = INT(ABS(ALBEND)) ALMIN = 60.0*(ABS(ALBEND) - FLOAT(IALB)) IALM = INT(ALMIN) ALSEC = 60.0*(ALMIN - FLOAT(IALM)) IALS = INT(ALSEC + 0.5) WRITE (NOUT,9055) XPRNT, YPRNT, IALB, IALM, IALS 9055 FORMAT (1H ,18X,'BEND',30X,F12.3,2X,F12.3,16X,I4,I3,I3) C C BEND POINT OF BEND STRING C 5175 IF (KLAB(NN) .LE. 1 .OR. JLAB(NN) .LT. KLAB(NN)) GO TO 5180 TANO = TAN(PI*AZBS/180.0) TANP = TAN(PI*AZPOS/180.0) TNSO = TAN(PI*SLBS/180.0) TNSP = TAN(PI*SLPOS/180.0) IF (TANO .EQ. TANP .AND. SLOLD .EQ. SLPOS) GO TO 5180 IF (TANO .NE. TANP) THEN ZBEND = (XPOS - XBS + ZBS*TANO - ZPOS*TANP)/(TANO - TANP) ELSE ZBEND = (YPOS - YBS + ZBS*TNSO - ZPOS*TNSP)/(TNSO - TNSP) ENDIF XBEND = XBS + TANO*(ZBEND - ZBS) XPRNT = -12.0*XBEND YPRNT = 12.0*ZBEND ALBEND = AZBS - AZPOS IF (ALBEND .LT. 0.0) ALBEND = ALBEND + 360.0 IALB = INT(ABS(ALBEND)) ALMIN = 60.0*(ABS(ALBEND) - FLOAT(IALB)) IALM = INT(ALMIN) ALSEC = 60.0*(ALMIN - FLOAT(IALM)) IALS = INT(ALSEC + 0.5) WRITE (NOUT,9056) XPRNT, YPRNT, IALB, IALM, IALS 9056 FORMAT (1H ,18X,'BEND STRING',23X,F12.3,2X,F12.3,16X,I4,I3,I3) AW4A1 = XPRNT AW4A2 = YPRNT AW4A3 = ALBEND WRITE (7,AWN3) C C ALAN WEHMANN LIST OF MAGNET CHARACTERISTICS C 5180 AW3A(1:10) = LPRNT AW3B = ELNAME AW3C(1:3) = 'FRD' AW3C(4:8) = FRDNO AW3D1 = ' ' DO 5181 J = 1, 70 5181 AW3D1(J:J) = CMMNT(J) AW3D2 = B AW3D3 = CURRNT AW3E = L/UFT AW3F = ALDEG AW3G = 0 AW3H = LCOLDF AW3I1A = XOLD AW3I1B = YOLD AW3I1C = ZOLD AW3I1D = ALOLD AW3I1E = AZOLD AW3I1F = PIOLD AW3I1G = SLOLD AW3I2A = XPOS AW3I2B = YPOS AW3I2C = ZPOS AW3I2D = ALPOS AW3I2E = AZPOS AW3I2F = PIPOS AW3I2G = SLPOS AW3J1A = XOLDS AW3J1B = YOLDS AW3J1C = ZOLDS AW3J1D = ALOLDS AW3J1E = AZCEN AW3J1F = PICEN AW3J1G = SLCEN AW3J2A = XPOSS AW3J2B = YPOSS AW3J2C = ZPOSS AW3J2D = ALPOSS AW3J2E = AZCEN AW3J2F = PICEN AW3J2G = SLCEN AW3K1A = ROCEN AW3K1B = ROCENC AW3K2A = ROCEN AW3K2B = ROCENC WRITE (7,AWN2) C 5200 RETURN END SUBROUTINE CSAVEX INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSH.CIN' INCLUDE 'OC.CIN' INCLUDE 'XYZOLD.CIN' C---------------------------------------------------------------- REAL POS(3) C LCOLD = LCPOS CURRNT = 0.0 DO 24 J = 1, 3 DO 24 K = 1, 3 OOLD(J,K) = O(4,J,K) 24 CONTINUE DO 25 J = 1, 3 POS(J) = X0(4,J) 25 CONTINUE XOLD = POS(1) YOLD = POS(2) ZOLD = POS(3) RETURN END SUBROUTINE CSET C C NO DESCRIPTION C C LIST OF COMMON BLOCKS C INCLUDE 'BSHEEL.CIN' INCLUDE 'BSH.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM16C.CIN' C C LOCAL VARIABLES C INTEGER J REAL POSS(3), UDEG C EQUIVALENCE (POSS(1), XPOS) C DATA UDEG /.0174532925/ C C---------------------------------------------------------------------- C J = NPARS IF (J .GE. 16 .AND. J .LE. 18) GO TO 160 IF (J .EQ. 19) GO TO 190 IF (J .EQ. 20) GO TO 200 GO TO 900 C C FLOOR COORDINATES OF BEGINNING OF BEAM C 160 CALL OSET J = NPARS - 15 POSS(J) = PARAM GO TO 900 C C INITIAL DIRECTION OF BEAM LINE C 190 CALL OSET AZPOS = TH/UDEG IF (AZPOS .LT. 0.0) AZPOS = AZPOS + 360.0 THINIT = TH GO TO 900 C 200 CALL OSET SLPOS = PH/UDEG PHINIT = PH GO TO 900 C 900 RETURN END SUBROUTINE ELCOMX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'OCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER ID, IDATA, IMIS, TYPEN REAL DATAR C IF (TYPE .EQ. 36) THEN TILT = .TRUE. ELSE IF (TYPE .EQ. 42) THEN IF (IPTOJ(3) .NE. 0) THEN ID = IPTOJ(3) IF (DATAR(I+ID) .NE. 0.0) TILT = .TRUE. ENDIF ELSE TILT = IPTOJ(NTILT) .NE. 0 ENDIF BEFORE = .TRUE. C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 RORC = MOD(TYT,10) IR = 3 DMC = LFM .GE. 1 NMIS = NUM4 ENDIF C IF (DMC) THEN TYPEC = 8 LXRAN = LFM .EQ. 2 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTEX CALL MPRINT ENDIF ENDIF ENDIF IF (LFM .EQ. 0 .AND. ALO(1) .AND. R2P) CALL UPDAT2 IF (LFM .EQ. 1 .AND. ALO(1) .AND. OCP(3)) CALL RESET(3) C LXRAN = .TRUE. IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TYPE .NE. 36) CALL POSTEX SONLY = .TRUE. CALL MPRINT SONLY = .FALSE. ENDIF ENDIF ENDIF C TOTRC = TOTROT TYPEC = 2 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) CALL POSTEX ENDIF ENDIF C IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) TYPEC = 4 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36 .OR. TYPE .EQ. 42) TYPEC = 35 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTEX ENDIF ENDIF C TYPEC = 2 BEFORE = .FALSE. IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) CALL POSTEX CALL VPRINT TYPEN = IDATA(ISTOR(NUM+NDIF)) IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .TRUE. CALL MPRINT IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .FALSE. ENDIF ENDIF C IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (TYPE .NE. 36) THEN IF (.NOT. LSTEPN) THEN CALL POSTEX CALL MPRINT ENDIF ENDIF ENDIF ENDIF C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 DMC = .TRUE. ENDIF C IF (DMC) THEN IF (NV3 .GE. 1) THEN IF (LFM .EQ. 0 .AND. (R2P .OR. R3P)) CALL UPDAT2 ELSE IF (LFM .EQ. 0 .AND. R2P) CALL UPDAT2 ENDIF TYPEC = 8 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTEX CALL MPRINT ENDIF ENDIF ENDIF RETURN END SUBROUTINE FITTINX C C READ IN DATA FOR NEXT CASE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSHEEL.CIN' INCLUDE 'BSH.CIN' INCLUDE 'COMMNT.CIN' INCLUDE 'COMMNX.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1B.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'DATA2C.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELNAM.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IODATA.CIN' INCLUDE 'IOFLAG.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LIMITS.CIN' INCLUDE 'NELN.CIN' INCLUDE 'NPLIN.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'RDCOMS.CIN' INCLUDE 'RDPRNT.CIN' INCLUDE 'RDWRDS.CIN' C C LOCAL VARIABLES C INTEGER IDATA, L, J, ICNT, ICMB, ITILT LOGICAL FLAG C C---------------------------------------------------------------- C READ AND PRINT TITLE AND INDICATOR C 1 LIST = .TRUE. RFM = .FALSE. BEF = .TRUE. PRNT = .TRUE. SLV = .TRUE. BWT = .FALSE. BRD = .FALSE. C ECHO = .FALSE. CALL TITLET IF (ENDFIL) STOP C 2 NORAYS = 0 CALL RDIND(FLAG) IF (LIST) THEN WRITE (NOUT,9001) WRITE (NOUT,9000) IMAGE IF (NCOMS .GT. 0) THEN L = LCOM WRITE (NOUT,1004) (CMMNT(J), J = 1, L), PARENC 1004 FORMAT (1H0,11X,1H(,79A1) ENDIF IF (SLV .OR. NORAYS .EQ. 0) WRITE (NOUT,9005) INDS IF (.NOT. SLV .AND. NORAYS .NE. 0) 1 WRITE (NOUT,9006) INDS, NORAYS ENDIF IF (FLAG) THEN WRITE (NOUT, 9010) INDIC = 0 ENDIF IF (INDS .NE. 0) GO TO 200 C C READ NEW SYSTEM C 100 ECHO = LIST .AND. .NOT. RFM NEL = 0 I = 1 ISTOR(1) = 1 ICNT = 1 ICMB = 1 ICOM(1) = 1 VBEND = .FALSE. FLUSHL = .FALSE. NUSE = 0 NMARKS = 0 ACCEL = .FALSE. LPRF = .FALSE. CALL UNITS(0) 110 CALL RDELMT IF (NTYPE .NE. 0) GO TO 119 IF (ICNT + NWORD .GT. 10000) GO TO 120 ICMB = ICNT DO 115 J = 1, NWORD COMMNT(ICNT) = CMMNT(J) ICNT = ICNT + 1 115 CONTINUE GO TO 120 119 IF (ICOM(NEL) .EQ. 0) ICOM(NEL) = ICMB ICOM(NEL+1) = ICNT 120 IF (NTYPE .EQ. 73) GO TO 400 GO TO 110 C C CONVERT INTERNAL VARY CODES TO EXTERNAL C 200 ECHO = LIST .AND. .NOT. RFM CALL RDVCEX 400 IF (LIST .AND. RFM) WRITE (NOUT,9400) C C CONVERT EXTERNAL VARY CODES TO INTERNAL C 500 IF (FLUSHL) WRITE (NOUT,9150) IF (FLUSHL .OR. LIST) WRITE (NOUT,9160) NEL, NELLIM, I, IDLIM IF (FLUSHL) GO TO 1 DO 520 NUM = 1, NEL I = ISTOR(NUM) NTYPE = IDATA(I) CALL SKETCH(NUM) IF (NTYPE .EQ. 1 .AND. .NOT. LPRF) PBEAM = DATA(I+7) IF (NTYPE .EQ. 16) THEN NPARS = INT(DATA(I+1)) IF (NPARS .EQ. 20 .AND. DATA(I+2) .NE. 0.0) VBEND = .TRUE. ENDIF IF (NTYPE .EQ. 20) THEN IF (ABS(ABS(DATA(I+1)) - 180.) .GT. 0.1) VBEND = .TRUE. ENDIF IF (NTYPE .EQ. 28 .OR. NTYPE .EQ. 29) THEN NTILT = 24 ITILT = IPTOJ(NTILT) IF (ITILT .NE. 0.0) THEN IF (DATA(I+ITILT) .NE. 0.0) VBEND = .TRUE. ENDIF ENDIF 520 CONTINUE CALL RDVCIN C C READ FILE OF FIELD MAPS C INSTALL OPEN STATEMENT SO THE FILE IS ACTUALLY OPENED!!!! C C OPEN (4, STATUS='OLD', FORM='FORMATTED', C > ACCESS='SEQUENTIAL', READONLY) C NELN = 1 610 READ (4,9170,END=700) ELNAM(NELN) NELN = NELN + 1 GO TO 610 700 NELN = NELN - 1 CLOSE(4) RETURN C 9000 FORMAT (2H0",A80,1H") 9001 FORMAT (1H1) 9005 FORMAT (1H0,I5) 9006 FORMAT (1H0,2I10) 9010 FORMAT (48H0INDICATOR VALUE WRONG OR MISSING - ZERO ASSUMED) 9150 FORMAT (21H0DATA OVERFLOW, NEL =,I4,6H I =,I5) 9160 FORMAT (1H0,I5,' ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE',I5/ 1 1H ,I5,' NUMBERS USED OUT OF A MAXIMUM ALLOWABLE',I6) 9170 FORMAT (A15) 9400 FORMAT (9H0SENTINEL) END SUBROUTINE INITBX C C LIST OF COMMON BLOCKS C INCLUDE 'BSHEEL.CIN' INCLUDE 'BSH.CIN' INCLUDE 'JKLABC.CIN' INCLUDE 'JKLABS.CIN' C C LOCAL VARIABLES C INTEGER J C--------------------------------------------------------------- LCPOS = 0.0 XPOS = 0.0 YPOS = 0.0 ZPOS = 0.0 AZPOS = 0.0 SLPOS = 0.0 ROPOS = 0.0 C C ZERO LABEL LIST C DO 4 J = 1, 100 4 JLAB(J) = 0 IF (IBSH .EQ. 0) THEN NLABS = 0 DO 5 J = 1, 100 LLIST(J) = ' ' KLAB(J) = 0 5 CONTINUE ENDIF RETURN END SUBROUTINE OUTFITX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSH.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'GRUMPF.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'STEPT1.CIN' INCLUDE 'XYZOLD.CIN' C C LOCAL VARIABLES C INTEGER IBEAM, IDATA C C--------------------------------------------------------------------- C C BEAM SHEET HEADING C CALL DATE(GRUMPF) IF (IBSH .GE. 1) WRITE (NOUT,8999) IMAGE, GRUMPF 8999 FORMAT (1H1,A80,2X,A9) CALL INITZE IBEAM = PBEAM IF (IBSH .EQ. 1 .AND. .NOT. VBEND) WRITE (NOUT,9100) IBEAM 9100 FORMAT (1H0,77X,I10,' GEV'/24X,'POSITION',40X,'POWER',6X, 1 'B/G(KG) OR '/5X,'Z CENT.',3X,'X CENT.',4X,'CODE',7X, 2 'ELEMENT CODE',23X,'SUPPLY',7X,'(KG/IN)'/) IF (IBSH .EQ. 1 .AND. VBEND) WRITE (NOUT,9101) IBEAM 9101 FORMAT (1H0,87X,I10,4H GEV/34X,'POSITION',40X,'POWER',6X, 1 'B/G(KG) OR '/5X,'Z CENT.',3X,'X CENT.',3X,'Y CENT.',4X, 2 'CODE',7X,'ELEMENT CODE',23X,'SUPPLY',7X,'(KG/IN)'/) IF (IBSH .EQ. 2) WRITE (NOUT,9102) 9102 FORMAT (1H0,'NAME',10X,'TYPE',11X,'STATION'/) IF (IBSH .EQ. 3) WRITE (NOUT,9103) 9103 FORMAT (1H0,'NAME',10X,'TYPE',10X,'FRD NO',9X,'STATION',7X, 1 'EASTING',6X,'NORTHING',8X,'HEIGHT',5X,'AZIMUTH',7X,'SLOPE', 2 6X,'ROLL'/) C C STEP THROUGH ELEMENTS C 10 I = ISTOR(NUM) TYPE = IDATA(I) TILT = .FALSE. IF (ATWORK) GO TO 20 IF (TYPE .EQ. 1 .OR. TYPE .EQ. 7 .OR. TYPE .EQ. 12 1 .OR. TYPE .EQ. 15 .OR. TYPE .EQ. 16 .OR. TYPE .EQ. 17 2 .OR. TYPE .EQ. 24 .OR. TYPE .EQ. 26 .OR. TYPE .EQ. 27 3 .OR. TYPE .EQ. 30) GO TO 20 GO TO 5200 C C TRAVERSE SINGLE ELEMENT C 20 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 CALL SKETCH(NUM) CALL DEPICT C C POSSIBLE INITIAL MISALIGNMENTS C CALL POSSIM C C SIMPLE ELEMENTS C IF (RABL .AND. WFRN) GO TO 200 IF (RABL) GO TO 100 CALL CSAVEX TOTRC = TOTROT TYPEC = TYPE LXRAN = TYPE .LT. 50 CALL ELICIT IF (MKG .AND. .NOT. MKDO) GO TO 5200 IF (TYPE .LT. 0 .OR. TYPE .GE. 50) GO TO 5200 IF (.NOT. LSTEPN) CALL POSTEX IF (TYPE .NE. 30 .AND. (TYPE .NE. 14 .OR. NEXT .NE. 14)) THEN IF (.NOT. LSTEPN) THEN CALL VPRINT CALL MPRINT CALL BPRINTX ENDIF ENDIF C C UPDATE USED TO MARK BEGINNING OF MISALIGNMENT C IF (TYPE .NE. 6 .AND. TYPE .NE. 37) GO TO 5200 CALL UPMARK GO TO 5200 C C SIMPLE ELEMENTS WITH POSSIBLE TILT C 100 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4) GO TO 150 CALL CSAVEX TOTRC = TOTROT CALL ELTILT IF (.NOT. LSTEPN) CALL BPRINTX GO TO 5200 C C BENDING MAGNETS WITH FRINGE FIELD SPECIFIED BY SEPARATE ELEMENT C 150 CALL CSAVEX TOTRC = TOTROT CALL EL242 IF (.NOT. LSTEPN) CALL BPRINTX GO TO 5200 C C COMPOUND ELEMENTS C 200 CALL CSAVEX TOTRC = TOTROT CALL ELCOMX L = LBEND IF (.NOT. LSTEPN) CALL BPRINTX C C ADVANCE TO NEXT ELEMENT C 5200 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 10 5300 CONTINUE RETURN END SUBROUTINE POSTEX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'COMMNT.CIN' INCLUDE 'COMMNX.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'SHFTS.CIN' C C LOCAL VARIABLES C INTEGER IADR, IB, ICOMB, ICOME, IDATA, ILEN, IG, IP, 1 J, TYPEP LOGICAL NBE, NRT, NARB REAL LEL, UIN REAL DATAR EXTERNAL DATAR C DATA UIN /2.54E-02/ C C----------------------------------------------------------- C NBE = .TRUE. NRT = .TRUE. NARB = .FALSE. IF (LABEL(NUM) .EQ. BLANK) GO TO 5000 ICOMB = ICOM(NUM) ICOME = ICOM(NUM + 1) ILEN = ICOME - ICOMB DO 50 J = 1, 78 50 CMMNT(J) = BLANK IF (ILEN .EQ. 0 .AND. TYPE .NE. 1 .AND. TYPE .NE. 4 1 .AND. TYPE .NE. 5 .AND. TYPE .NE. 18) GO TO 5000 IF (ILEN .EQ. 0) GO TO 80 ILEN = MIN0(ILEN,78) DO 60 J = 1, ILEN 60 CMMNT(J) = COMMNT(ICOMB + J - 1) 80 IF (TYPE .EQ. 4) GO TO 400 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 18) GO TO 1800 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 400 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) GO TO 3500 GO TO 5000 C C 4. -- BENDING MAGNET C 400 LEL = LBEND IF (ILEN .EQ. 0) THEN IP = ISTOR(NUM-1) TYPEP = IDATA(IP) IF (TYPEP .NE. 2) GO TO 5000 ICOMB = ICOM(NUM-1) ICOME = ICOM(NUM) ILEN = ICOME - ICOMB IF (ILEN .EQ. 0) GO TO 5000 DO 410 J = 1, ILEN 410 CMMNT(J) = COMMNT(ICOMB + J - 1) ENDIF GO TO 5000 C C 5. -- QUADRUPOLE C 500 IG = IPTOJ(4) IF (IG .NE. 0) GO TO 510 B = DATA(I+2)*RI/PREF AP = DATA(I+3)*UNITI(1)/UIN B = B/AP GO TO 5000 C 510 B = DATA(I+2)*RI*UIN/(UNITI(1)*PREF) GO TO 5000 C C 18. -- SEXTUPOLE C 1800 B = DATA(I+2)*RI/PREF AP = DATA(I+3)*UNITI(1)/UIN B = B/AP**2 GO TO 5000 C C 35. OR 36. -- HKICK OR VKICK C 3500 NB = 2 IB = IPTOJ(NB) IADR = I + IB B = DATAR(IADR) B = B*UNITI(9)*RI/PREF GO TO 5000 5000 RETURN END SUBROUTINE SURVEYX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSHEEL.CIN' INCLUDE 'BSH.CIN' INCLUDE 'BSHIN.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM16C.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' C C LOCAL VARIABLES C INTEGER J REAL ALONG, PITCH, POS(3), ROLL, SHIFT, YAW REAL CSX, SNX, SNY, CSZ, SNZ C---------------------------------------------------------- C ALONG = LC XPIN = XINIT YPIN = YINIT ZPIN = ZINIT THPIN = THINIT PHPIN = PHINIT DO 10 J = 1, 3 POS(J) = X0(4,J) 10 CONTINUE C CSX = O(4,3,3) SNX = O(4,3,1) YAW = ATAN(SNX/CSX) IF (CSX .GE. 0.0) GO TO 11 SHIFT = SIGN(PI,SNX) YAW = YAW + SHIFT 11 AZPOS = YAW IF (AZPOS .LT. 0.0) AZPOS = AZPOS + 2.0*PI C SNY = O(4,3,2) PITCH = ASIN(SNY) C SNZ = O(4,1,2) CSZ = O(4,2,2) IF (CSZ .NE. 0.0) ROLL = ATAN(SNZ/CSZ) IF (CSZ .EQ. 0.0 .AND. SNZ .GT. 0.0) ROLL = 0.5*PI IF (CSZ .EQ. 0.0 .AND. SNZ .LT. 0.0) ROLL = - 0.5*PI IF (CSZ .GE. 0.0) GO TO 13 SHIFT = SIGN(PI,SNZ) ROLL = ROLL + SHIFT 13 IF (REFER) ROLL = ROLL + TOTROT C LCPOS = LC XPOS = POS(1) YPOS = POS(2) ZPOS = POS(3) LCPR = .TRUE. RETURN END SUBROUTINE TITLET C C---- PERFORM "TITLE" COMMAND C C LIST OF COMMON BLOCKS C INCLUDE 'BSHEEL.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'IODATA.CIN' INCLUDE 'IOFLAG.CIN' INCLUDE 'RDBUFF.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' C LOGICAL LEMP, REMP, LPAREN, RPAREN, BWORD INTEGER I, IBEG, IEND, ILAST, IST INTEGER J, JJ, JMAX, LEVEL, LNAME, LTEMP C CHARACTER*15 KNAME CHARACTER*1 ITEMP, ITEMA, ITEMB, LCOMP(2), STRING(80) C EQUIVALENCE (LCOMP(1),LABEAM) EQUIVALENCE (STRING(1),IMAGE) C C-------------------------------------------------------------------- CALL RDLINE IF (ENDFIL) THEN IMAGE = ' ' STOP ELSE IBEG = 1 10 CALL RDNEXT ITEM = KLINE(ICOL) IF (ITEM .EQ. QUOTE .OR. ITEM .EQ. APOST) THEN IBEG = ICOL + 1 GO TO 20 ELSE IF (INDEX(ALPHA,ITEM) .NE. 0) THEN CALL RDWORD(KNAME,LNAME) IF (KNAME(1:4) .EQ. 'SENT') STOP GO TO 10 ENDIF C 20 IST = IBEG DO 30 I = IST, 80 ILAST = I ITEM = KLINE(I) IF (ITEM .EQ. BLANK) GO TO 30 IF (ITEM .EQ. QUOTE .OR. ITEM .EQ. APOST) GO TO 80 IBEG = I GO TO 40 30 CONTINUE C 40 IF (IBEG .LT. 80) GO TO 50 IBEG = 1 IEND = 80 GO TO 100 C 50 IEND = 80 IST = IBEG DO 60 I = IST, 80 ITEM = KLINE(I) IF (ITEM .NE. QUOTE .AND. ITEM .NE. APOST) GO TO 60 IEND = I - 1 GO TO 100 60 CONTINUE GO TO 100 80 IEND = ILAST - 1 100 IMAGE = KTEXT(IBEG:IEND) ENDIF ICOL = 81 C C EXTRACT BEAM LINE NAME FROM TITLE C LABEAM = BLANK LEVEL = 0 JMAX = 36 DO 200 I = 1, IEND ITEM = STRING(I) IF (ITEM .NE. 'M' .AND. ITEM .NE. 'N' .AND. ITEM .NE. 'P') 1 GO TO 200 ITEMP = STRING(I+1) DO 120 J = 1, JMAX JJ = J IF (ITEMP .EQ. TABLE(J)) GO TO 130 120 CONTINUE GO TO 200 C 130 LEMP = I .EQ. 1 LPAREN = .FALSE. IF (LEMP) GO TO 140 ITEMB = STRING(I-1) LEMP = ITEMB .EQ. BLANK LPAREN = ITEMB .EQ. PARENO C 140 REMP = I .EQ. IEND - 1 RPAREN = .FALSE. IF (REMP) GO TO 150 ITEMA = STRING(I+2) REMP = ITEMA .EQ. BLANK .OR. ITEMA .EQ. COMMA RPAREN = ITEMB .EQ. PARENC C 150 BWORD = .FALSE. IF (I .LT. 6) GO TO 160 BWORD = IMAGE(I-5:I-2) .EQ. 'BEAM' IF (BWORD) GO TO 170 C 160 IF (I .GT. IEND - 6) GO TO 170 BWORD = IMAGE(I+3:I+7) .EQ. 'BEAM' C 170 LTEMP = 1 IF (LPAREN .AND. RPAREN) LTEMP = 2 IF (LEMP .OR. REMP) LTEMP = 3 IF (LEMP .AND. REMP) LTEMP = 4 IF (BWORD) LTEMP = LTEMP + 4 IF (LTEMP .LE. LEVEL) GO TO 200 LEVEL = LTEMP LCOMP(1) = ITEM LCOMP(2) = ITEMP IF (LEVEL .EQ. 8) GO TO 210 200 CONTINUE C 210 RETURN END