C SUBROUTINE FILE 'WRIT.FOR' TO CREATE THE OUTPUT FILES OF COMPLETE RAY C TRACING C C BY VLASTISLAV CERVENY, LUDEK KLIMES, IVAN PSENCIK C C THIS FILE CONSISTS OF: C WRITB...BLOCK DATA SUBROUTINE DEFINING COMMON BLOCKS /WRITT/, C /WRITC/ AND /WRITN/ TO STORE THE INPUT DATA ON THE NAMES C OF OUTPUT FILES. C WRIT1...SUBROUTINE CALLED WHEN STARTING THE COMPLETE RAY TRACING C PROGRAM, AND WHEN STARTING THE COMPUTATION OF A NEW C ELEMENTARY WAVE. C WRIT2...SUBROUTINE CALLED WHEN STARTING THE COMPLETE TRACING OF A C NEW RAY. C WRIT31..SUBROUTINE STORING THE COMPUTED QUANTITIES ALONG A RAY C (C.R.T.5.5.1). IT IS CALLED WITH CONSTANT STEP STORE (SEE C INPUT DATA IN THE FILE 'RAY.FOR') OF THE INDEPENDENT C VARIABLE ALONG THE RAY, AND AT THE POINTS OF INTERSECTION C WITH INTERFACES EITHER BEFORE AND AFTER THE C TRANSFORMATION. C WRIT32..SUBROUTINE STORING THE COMPUTED QUANTITIES AT SPECIFIED C SURFACES (C.R.T.5.5.2). IT IS CALLED AT THE POINTS OF C INTERSECTION OF THE RAY WITH THE SPECIFIED SURFACES. C WRIT33..SUBROUTINE STORING THE COMPUTED QUANTITIES AT THE C ENDPOINTS OF THE INDIVIDUAL ELEMENTARY WAVES C (C.R.T.5.5.3). IT IS CALLED AT THE ENDPOINTS OF THE C ELEMENTS OF RAYS, SITUATED AT STRUCTURAL INTERFACES. C WRIT4...SUBROUTINE STORING THE QUANTITIES AT THE INITIAL POINT OF C THE RAY (C.R.T.6.1). IT IS CALLED AFTER TERMINATION OF C TRACING THE RAY. C CHECK...AUXILIARY SUBROUTINE TO WRIT4. C WRIT5...SUBROUTINE CALLED AFTER TERMINATION OF THE COMPUTATION OF C AN ELEMENTARY WAVE, AND WHEN TERMINATING THE COMPLETE RAY C TRACING PROGRAM. C FNAME...SUBROUTINE ANALYSING THE SPECIFIED STRINGS AND COMPOSING C THE FILENAME OF THEM. AUXILIARY SUBROUTINE TO WRIT1. C C INPUT DATA TO SPECIFY THE NAMES OF THE OUTPUT FILES WITH THE COMPUTED C QUANTITIES: C THE DATA ARE READ IN BY THE LIST DIRECTED INPUT (FREE FORMAT). IN C THE LIST OF INPUT DATA BELOW, EACH NUMBERED PARAGRAPH INDICATES C THE BEGINNING OF A NEW INPUT OPERATION (NEW READ STATEMENT). ALL C INPUT VARIABLES ARE OF THE TYPE CHARACTER. THE DATA ARE READ BY C THE SUBROUTINE WRIT1. C THE FILENAMES ARE GENERATED USING SEVERAL COMPONENTS (STRINGS) IN C THE FOLLOWING WAY: EACH COMPONENT (STRING) IS DIVIDED INTO WORDS, C EACH WORD BEING FOLLOWED BY JUST ONE SPACE. HERE A WORD IS A C SUBSTRING CONTAINING NO SPACE, PRECEDED AND FOLLOWED BY SPACES OR C BY THE BEGINNING OR END OF THE STRING. AN EMPTY WORD LIES BETWEEN C TWO CONSECUTIVE SPACES. THE FILENAME IS COMPOSED OF C THE 1-ST WORD OF THE 1-ST COMPONENT, C THE 1-ST WORD OF THE 2-ND COMPONENT, C ... C THE 1-ST WORD OF THE LAST COMPONENT, C THE 2-ND WORD OF THE 1-ST COMPONENT, C THE 2-ND WORD OF THE 2-ND COMPONENT, C ... C THE LAST WORD OF THE LAST COMPONENT. C EXAMPLE: C 1-ST COMPONENT = 'D/ .OUT', C 2-ND COMPONENT = 'A B', C 3-RD COMPONENT = '1 2', C RESULTING FILENAME = 'D/A1B2.OUT'. C NOTE THAT ONLY FIRST 16 CHARACTERS OF EACH FILENAME COMPONENT ARE C SIGNIFICANT. C (1) TEXTW C STRING DESCRIBING THE DATA. ONLY THE FIRST 80 CHARACTERS OF THE C STRING ARE SIGNIFICANT. C (2) FN1A,FN1I,/ C FN1A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED ALONG THE C RAYS (C.R.T.5.5.1). C FN1I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF C RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE C COMPUTED QUANTITIES STORED ALONG THE RAYS (C.R.T.5.5.1). C THE OTHER COMPONENTS OF THE FILENAME ARE COMMON WITH THE C RELATED FILE CONTAINING THE COMPUTED QUANTITIES. C /... AN OBLIGATORY SLASH. C DEFAULT: ALL FILENAMES BLANK. C (3) FN2A,FN2I,(FN2B(I),I=1,NENDF),/ C FN2A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C SPECIFIED SURFACES (C.R.T.5.5.2). C FN2I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF C RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE C COMPUTED QUANTITIES STORED AT THE SPECIFIED SURFACES C (C.R.T.5.5.2). THE OTHER COMPONENTS OF THE FILENAME ARE C COMMON WITH THE RELATED FILE CONTAINING THE COMPUTED C QUANTITIES. C FN2B(I)... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF C THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C I-TH SPECIFIED SURFACE (C.R.T.5.5.2). HERE NENDF IS THE C NUMBER OF SURFACES SPECIFIED FOR STORING THE COMPUTED C QUANTITIES. C /... AN OBLIGATORY SLASH. C DEFAULT: ALL FILENAMES BLANK. C (4) EITHER (4.1) OR (4.2): C (4.1) / C A SLASH IS FULLY SUFFICIENT IF MODCRT.LE.1, SEE INPUT DATA C 'DCRT.DAT' DESCRIBED IN SOURCE CODE FILE 'RAY.FOR'. C IF MODCRT.LE.1, THE FILENAMES (4.2) ARE IGNORED IF SPECIFIED. C IF MODCRT.GE.2, THE FILENAMES (4.2) ARE OBLIGATORY. C (4.2) FN3A,FN3I,(FN3B(I),I=1,NELEM),/ C FN3A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C ENDPOINTS OF THE ELEMENTS OF RAYS (C.R.T.5.5.3). C FN3I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF C RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE C COMPUTED QUANTITIES STORED AT THE ENDPOINTS OF THE C ELEMENTS OF RAYS (C.R.T.5.5.3). THE OTHER COMPONENTS OF C THE FILENAME ARE COMMON WITH THE RELATED FILE CONTAINING C THE COMPUTED QUANTITIES. C FN3B(I)... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF C THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C ENDPOINTS OF THE I-TH ELEMENT OF RAYS (C.R.T.5.5.3). C THESE STRINGS NEED NOT BE SPECIFIED FOR MODCRT.LE.1, SEE C INPUT DATA 'DCRT.DAT'. OTHERWISE, NONE OF FN3B(I) C CORRESPONDING TO THE ENDPOINT OF A RAY ELEMENT AT WHICH C QUANTITIES ARE STORED (SEE MODCRT IN THE INPUT DATA C 'DCRT.DAT') MAY EQUAL SPACES. C /... AN OBLIGATORY SLASH. C DEFAULT: ALL FILENAMES BLANK. C (5) FOR EACH ELEMENTARY WAVE IWAVE THE FOLLOWING DATA (5.1): C (5.1) FN1C,FN2C,FN3C,(FN2D(I),I=1,NENDF),/ C FN1C... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED ALONG THE C RAYS (C.R.T.5.5.1). C IF BOTH THE FIRST AND SECOND COMPONENT OF THE FILENAME ARE C BLANK, THE FILE IS NOT CREATED. C FN2C... STRING CONTAINING THE THIRD COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C SPECIFIED SURFACES (C.R.T.5.5.2). C IF THE SECOND, THIRD AND FOURTH COMPONENTS OF THE FILENAME C ARE ALL BLANK, THE FILE IS NOT CREATED. C FN3C... STRING CONTAINING THE THIRD COMPONENT OF THE NAME OF THE C OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C ENDPOINTS OF THE ELEMENTS OF RAYS (C.R.T.5.5.3). C THIS STRING MAY NOT EQUAL SPACES FOR MODCRT.GE.2, SEE C INPUT DATA 'DCRT.DAT'. C IF MODCRT.LE.1, SEE INPUT DATA 'DCRT.DAT', THE FILE IS NOT C CREATED. C FN2D(I)... STRING CONTAINING THE FOURTH COMPONENT OF THE NAME OF C THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE C I-TH SPECIFIED SURFACE (C.R.T.5.5.2). HERE NENDF IS THE C NUMBER OF SURFACES SPECIFIED FOR STORING THE COMPUTED C QUANTITIES. C /... AN OBLIGATORY SLASH. C DEFAULT: ALL FILENAMES BLANK. C C STORAGE IN THE MEMORY: C THE INPUT DATA (1) TO (5) DESCRIBING THE NAMES OF THE OUTPUT FILES C WITH THE COMPUTED QUANTITIES ARE STORED IN THE COMMON BLOCK C /WRITT/. OTHER IMPORTANT VARIABLES SHARED BY THE SUBROUTINES OF C THIS FILE ARE STORED IN THE COMMON BLOCKS /WRITC/ AND /WRITN/. C THE COMMON BLOCKS ARE DEFINED IN THE FOLLOWING SUBROUTINE: C ------------------------------------------------------------------ BLOCK DATA WRITB INTEGER MF PARAMETER (MF=64) CHARACTER*80 TEXTW CHARACTER*16 FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C CHARACTER*16 FN2D(MF) COMMON/WRITT/TEXTW, * FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB,FN1C,FN2C,FN3C,FN2D SAVE /WRITT/ INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR SAVE /WRITC/ CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 SAVE /WRITN/ DATA LUW/10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25/ DATA JENDR/10,21,22,23,24,25,26,30,32,33,40,50,60,61,71,72,74/ END C ------------------------------------------------------------------ C TEXTW...THE NAME OF THE DATA SET. STRING OF 80 CHARACTERS. C FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C... STORAGE C LOCATIONS FOR THE INPUT DATA (2) TO (5). C THE COMMON BLOCK /WRITT/ IS USED JUST IN THE SUBROUTINE C WRIT1. C JWAVE...INDEX OF THE CURRENT ELEMENTARY WAVE. C JRAY... INDEX OF THE CURRENT RAY. C JUEB... COUNT OF RAYS EXCEEDING THE SPECIFIED UPPER BOUNDS OF THE C CHECKED QUANTITIES. C JFCT... TOTAL NUMBER OF INVOCATIONS OF THE SUBROUTINE FCT. C JOUTP...TOTAL NUMBER OF STEPS OF THE NUMERICAL INTEGRATION. C JTRANS..TOTAL NUMBER OF INVOCATIONS OF THE SUBROUTINE TRANS. C KWRIT1,KWRIT2,KWRIT3... NUMBERS OF INITIAL RAY ELEMENTS ALONG C WHICH NOTHING IS STORED IN THE SUBROUTINES WRIT31, WRIT32 C AND WRIT33, RESPECTIVELY. C NF1... NUMBER OF OPEN FILES, SEE THE INPUT DATA (2) AND THE C SUBROUTINE WRIT31. C NF2... NUMBER OF OPEN FILES, SEE THE INPUT DATA (3) AND THE C SUBROUTINE WRIT32. C NF3... NUMBER OF OPEN FILES, SEE THE INPUT DATA (4) AND THE C SUBROUTINE WRIT33. C MF3... NUMBER OF FILES CORRESPONDING TO THE CURRENT ELEMENTARY C WAVE, SEE THE INPUT DATA (4) AND THE SUBROUTINE WRIT33. C NUW... THE MAXIMUM COUNT OF AVAILABLE LOGICAL UNIT NUMBERS. C LUW... LIST OF THE LOGICAL UNIT NUMBERS CORRESPONDING TO THE C OUTPUT FILES. C JPOINT..ARRAY CONTAINING NUMBERS OF POINTS STORED INTO THE FILES. C JSTOR(I)... THE NUMBER OF CROSSECTIONS OF THE COMPUTED RAY WITH C THE SURFACE KSTOR(I). BECAUSE, FOR THE STRUCTURAL C INTERFACES, THE POSITIVE OR NEGATIVE SIDE OF THE SURFACE C IS SPECIFIED, EITHER ZERO OR TWO CROSSECTIONS CORRESPOND C TO THE REFLECTION FROM THE SURFACE KSTOR(I). C MENDR...TOTAL NUMBER OF DISTINCT REASONS OF THE TERMINATION OF THE C COMPUTATION OF THE RAY, SEE SUBROUTINE RAY2 OF THE FILE C 'RAY.FOR' AND SUBROUTINE INIT2 OF THE FILE 'INIT.FOR'. C JENDR...LIST OF THE INDICES CORRESPONDING TO DISTINCT REASONS OF C THE TERMINATION OF THE COMPUTATION OF THE RAY, SEE C SUBROUTINE RAY2 OF THE FILE 'RAY.FOR' AND SUBROUTINE INIT2 C OF THE FILE 'INIT.FOR'. C NENDR...NENDR(I),I=1,MENDR... NUMBER OF RAYS TERMINATED FOR THE C REASON JENDR(I). C NENDR(MENDR+1)... NUMBER OF RAYS TERMINATED FOR THE REASON C NOT LISTED IN THE ARRAY JENDR. C NENDR(MENDR+2)... TOTAL NUMBER OF COMPUTED RAYS OF THE C CURRENT ELEMENTARY WAVE. C NAME2...LIST OF THE NAMES OF THE OPEN FILES. C C OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED ALONG THE RAYS C (C.R.T.5.5.1): C UNFORMATTED OUTPUT. THE COMPUTED QUANTITIES ARE STORED WITH THE C STEP STORE (SEE THE INPUT DATA IN THE SUBROUTINE FILE 'RAY.FOR') C ALONG ALL RAYS, AND AT ALL POINTS OF INTERSECTION OF RAYS WITH C STRUCTURAL INTERFACES EITHER BEFORE AND AFTER THE TRANSFORMATION. C FOR EACH POINT - ONE RECORD CONTAINING THE FOLLOWING QUANTITIES: C (1) IWAVE,IRAY,NY,ICB1,ISRF,X,(YL(I),I=1,6),(Y(I),I=1,NY) C IWAVE...INDEX OF THE ELEMENTARY WAVE (OUTPUT OF THE SUBROUTINE C CODE1). ELEMENTARY WAVES ARE INDEXED BY 1,2,3,... . C IRAY... INDEX OF THE RAY (OUTPUT OF THE SUBROUTINE RPAR2). RAYS C WITHIN EACH ELEMENTARY WAVE ARE INDEXED BY 1,2,3,... . C NOTE THAT SOME OF THE INDEXED RAYS NEED NOT EXIST. C NY=IY(1)=27+NAMPL... NUMBER OF THE BASIC QUANTITIES DESCRIBING THE C POINT OF THE RAY, SEE THE FILE 'RAY.FOR'. C ICB1=IY(5)... INDEX OF THE COMPLEX BLOCK IN WHICH THE STORED POINT C OF THE RAY IS SITUATED, SUPPLEMENTED BY A SIGN '+' FOR P C WAVE AND SIGN '-' FOR S WAVE. C ISRF=IY(6)... INDEX OF THE SURFACE AT WHICH THE ENDPOINT OF THE C COMPUTED ELEMENT OF THE RAY IS SITUATED, SUPPLEMENTED BY C A SIGN '+' OR '-' FOR THE ENDPOINT SITUATED AT THE C POSITIVE OR NEGATIVE SIDE OF THE SURFACE, RESPECTIVELY. C ZERO INSIDE THE COMPLEX BLOCK. NOTE: THE SIGN OF THIS C QUANTITY IS THE EXEPTION TO THE DEFINITION IN THE ORIGINAL C PAPER ON C.R.T. C X... INDEPENDENT VARIABLE ALONG A RAY (SEE YY(1) IN C C.R.T.5.2.2). C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY C (C.R.T.5.5.4). C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY C (C.R.T.5.2.1). C THE DETAILED DESCRIPTION OF THE QUANTITIES YL, YY AND IY MAY BE C FOUND IN THE FILE 'RAY.FOR'. C C OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED AT THE SPECIFIED C SURFACES (C.R.T.5.5.2): C UNFORMATTED OUTPUT. THE COMPUTED QUANTITIES ARE STORED AT THE C POINTS OF INTERSECTION OF RAYS WITH THE SPECIFIED SURFACES. C FOR EACH POINT - ONE RECORD CONTAINING THE FOLLOWING QUANTITIES: C (1) IWAVE,IRAY,NY,ICB1,ISRF,X,(YL(I),I=1,6),(Y(I),I=1,NY) C THE SAME QUANTITIES AS IN THE DATA SET DESCRIBED ABOVE, EXCEPT C THAT THE VECTORIAL REDUCED AMPLITUDES Y(28)-Y(IY(1)) MAY (BUT NEED C NOT) BE REPLACED BY THE REDUCED AMPLITUDES YC(1) TO YC(NY-27) C INVOLVING APPROPRIATE CONVERSION COEFFICIENTS, SEE C.R.T.5.5.4. C YC(1) TO YC(NY-27) ARE DESCRIBED IN THE SUBROUTINE CONV (FILR C 'TRANS.FOR') AND IN THE SUBROUTINE WRIT32 (THIS FILE). NOTE THAT C NY=33 FOR P WAVE AND NY=39 FOR S WAVE AT THE INITIAL POINT OF THE C RAY. C C OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED AT THE ENDPOINTS OF C THE ELEMENTS OF RAYS (C.R.T.5.5.3): C UNFORMATTED OUTPUT. THE FILES, GENERATED ONLY IF KSTORE.GE.2 (SEE C INPUT DATA IN THE SUBROUTINE FILE 'RAY.FOR'), ARE AUXILIARY DISK C STORAGE LOCATIONS TO THE PROGRAM CRT AND ARE NOT INTENDED TO BE C THE OUTPUT OF THE COMPLETE RAY TRACING USED BY THE USER C APPLICATION PROGRAMS. THE COMPUTED QUANTITIES ARE STORED AT THE C ENDPOINTS OF THE ELEMENTS OF ALL RAYS BEFORE THE TRANSFORMATION. C FOR EACH POINT - ONE RECORD CONTAINING THE FOLLOWING QUANTITIES: C (1) IRAY,(IY(I),I=1,12),(YL(I),I=1,6),(Y(I),I=1,IY(1)),(YY(I),I=1,5) C IRAY... INDEX OF THE RAY (OUTPUT OF THE SUBROUTINE RPAR2). RAYS C WITHIN EACH ELEMENTARY WAVE ARE INDEXED BY 1,2,3,... . C NOTE THAT SOME OF THE INDEXED RAYS MAY NOT EXIST. C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY. C (C.R.T.5.5.4). C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY. C (C.R.T.5.2.1). C YY... ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG C THE RAY (C.R.T.5.2.2). C IY... ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED C ALONG THE RAY (C.R.T.5.2.2). C THE DETAILED DESCRIPTION OF THE QUANTITIES YL, Y, YY AND IY MAY BE C FOUND IN THE FILE 'RAY.FOR'. C C OUTPUT FILES WITH THE QUANTITIES AT THE INITIAL POINTS OF RAYS C (C.R.T.6.1): C UNFORMATTED OUTPUT. THE QUANTITIES ARE STORED AT THE INITIAL C POINTS OF ALL RAYS. C FOR EACH RAY - ONE RECORD CONTAINING FOLLOWING 34 QUANTITIES: C (1) (-IWAVE),IRAY,ICB1I,IEND,ISHEET,(YLI(I),I=1,6),(YI(I),I=1,25) C IWAVE...INDEX OF THE ELEMENTARY WAVE (OUTPUT OF THE SUBROUTINE C CODE1). ELEMENTARY WAVES ARE INDEXED BY 1,2,3,... . C IRAY... INDEX OF THE RAY (OUTPUT OF THE SUBROUTINE RPAR2). RAYS C WITHIN EACH ELEMENTARY WAVE ARE INDEXED BY 1,2,3,... . C NOTE THAT SOME OF THE INDEXED RAYS MAY NOT EXIST. C ICB1I...INDEX OF THE COMPLEX BLOCK IN WHICH THE INITIAL POINT OF C THE RAY IS SITUATED, SUPPLEMENTED BY A SIGN '+' FOR P WAVE C AND SIGN '-' FOR S WAVE (SEE C.R.T.6.1). C IEND... REASON OF THE TERMINATION OF THE COMPUTATION OF A RAY (SEE C C.R.T.5.4). FOR A DETAILED DESCRIPTION SEE SUBROUTINES C RAY2 (FILE 'RAY.FOR') AND INIT2 (FILE 'INIT.FOR'). C ISHEET..RAY-HISTORY INDEX. THE DIFFERENT RAY HISTORIES ARE C CONSECUTIVELY INDEXED BY POSITIVE INTEGERS 1,2,3,... C ACCORDING TO THEIR APPEARANCE DURING RAY TRACING. C THE RAY HISTORIES ARE INDEXED INDEPENDENTLY WITHIN EACH C ELEMENTARY WAVE. THE INDICES ARE THE OUTPUT OF SUBROUTINE C RPAR4 OF THE FILE 'RPAR.FOR'. C THE RAY-HISTORY INDICES ARE COMPLEMENTED WITH SIGN: C POSITIVE - SUCCESSFUL RAY (CROSSING REFERENCE SURFACE), C NEGATIVE - UNSUCCESSFUL RAY (TERMINATING BEFORE CROSSING C REFERENCE SURFACE). C YLI... ARRAY CONTAINING THE VALUES OF THE QUANTITIES YL(1)-YL(6), C SEE C.R.T.5.5.4, DESCRIBING THE LOCAL PROPERTIES OF THE C MODEL AT THE INITIAL POINT OF THE RAY. SEE THE LIST OF C YL(1) TO YL(6) IN THE FILE 'RAY.FOR'. C YI... ARRAY CONTAINING THE QUANTITIES DESCRIBING THE PROPERTIES C OF THE RAYS AND OF THE TRAVEL-TIME FIELD AT THE INITIAL C POINT OF THE RAY, SEE C.R.T.6.1. THESE QUANTITIES ARE C LISTED IN THE FILE 'INIT.FOR'. C C DATE: 1994, JANUARY 23 C CODED BY LUDEK KLIMES C C======================================================================= C SUBROUTINE WRIT1(LUN,LULOG,IWAVE,IWAVE0,IKODE) INTEGER LUN,LULOG,IWAVE,IWAVE0,IKODE C C THIS SUBROUTINE IS CALLED WHEN STARTING THE COMPLETE RAY TRACING C PROGRAM, AND WHEN STARTING THE COMPUTATION OF A NEW ELEMENTARY WAVE. C C INPUT: C LUN... LOGICAL UNIT NUMBER OF THE EXTERNAL INPUT DEVICE C CONTAINING THE INPUT DATA. C LULOG...LOGICAL UNIT NUMBER OF THE LOG OUTPUT DEVICE. C IWAVE...ZERO WHEN STARTING THE COMPLETE RAY TRACING PROGRAM, C OTHERWISE THE INDEX OF THE ELEMENTARY WAVE WHICH WILL BE C COMPUTED (I.E. THE OUTPUT OF THE SUBROUTINE CODE1 FROM THE C FILE 'CODE.FOR'). C IWAVE0..INDEX OF THE ALREADY COMPUTED ELEMENTARY WAVE HAVING THE C MOST NUMEROUS COMMON ELEMENTS WITH THE CURRENT ELEMENTARY C WAVE. NEED NOT BE DEFINED IF IWAVE=0. C IKODE...THE LENGTH OF THE COMMON PART OF THE CODES OF THE IWAVE-TH C AND IWAVE0-TH ELEMENTARY WAVES. NEED NOT BE DEFINED IF C IWAVE=0. C C NO OUTPUT. C C COMMON BLOCK /DCRT/ (SEE SUBROUTINE FILE 'RAY.FOR'): INTEGER MEND,MSTOR PARAMETER (MEND=128) PARAMETER (MSTOR=128) INTEGER KSTORE,NEXPS,NHLF,MODCRT REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7) INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR) COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH, * UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C COMMON BLOCK /WRITT/: INTEGER MF PARAMETER (MF=64) CHARACTER*80 TEXTW CHARACTER*16 FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C CHARACTER*16 FN2D(MF) COMMON/WRITT/TEXTW, * FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB,FN1C,FN2C,FN3C,FN2D C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C ALL THE STORAGE LOCATIONS OF THE COMMON BLOCKS ARE DEFINED IN THIS C SUBROUTINE. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: INTEGER LCODE,NELEM EXTERNAL WRITB,LCODE,NELEM,SCRO1,FNAME C WRITB.. BLOCK DATA SUBROUTINE OF THIS FILE. C LCODE,NELEM... FILE 'CODE.FOR'. C SCRO1... FILE 'SCRO.FOR'. C FNAME... THIS FILE. C C ERROR MESSAGES: C 551... OPEN FILE ERROR: C OPEN FILE ERROR WHEN OPENING THE FILE TO STORE: C 1 COMPUTED QUANTITIES ALONG THE RAYS. C 2 COMPUTED QUANTITIES AT THE SPECIFIED SURFACES. C 3 COMPUTED QUANTITIES AT THE ENDPOINTS OF THE ELEMENTS OF C THE RAYS OF THE ELEMENTARY WAVE. C 4 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING C TO THE ABOVE FILE 1. C 5 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING C TO THE ABOVE FILE 2. C 6 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING C TO THE ABOVE FILE 3. C THE TYPE 1 TO 6 OF THE FILE IS GIVEN BY THE FIRST DECIMAL C PLACE OF THE STATUS. C 554... FEW LOGICAL UNITS AVAILABLE: C THERE ARE NUW LOGICAL UNITS AVAILABLE, SEE THE COMMON C BLOCKS /WRITC/ AND /WRITN/ DEFINED IN THE BLOCK DATA C WRITB. THIS NUMBER SHOULD BE INCREASED. C 556... FEW FILENAMES SPECIFIED: C THERE ARE MORE ELEMENTS OF THE RAYS OF AN ELEMENTARY WAVE C THAN THE CORRESPONDING SPECIFIED FILENAMES. C 557... FEW FILENAMES SPECIFIED: C THERE ARE MORE REQUIRED ELEMENTARY WAVES THAN THE C CORRESPONDING SPECIFIED FILENAMES. C 558... END OF INPUT FILE: C END OF INPUT DATA FILE WRIT SPECIFYING THE NAMES OF THE C OUTPUT FILES ENCOUNTERED BEFORE ALL REQUIRED ELEMENTARY C WAVES ARE COMPUTED. THE NUMBER OF ELEMENTARY WAVES C EXCEEDS THE NUMBER OF SPECIFIED OUTPUT FILENAMES. C C DATE: 1993, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER NKODE,IE1,IE2,I,J CHARACTER*16 NAME1(4) C IF(IWAVE.LE.0) THEN C C READING THE NAME OF THE INPUT DATA READ(LUN,*) TEXTW C C READING STRINGS COMPOSING THE NAMES OF OUTPUT FILES (CRT.5.5.1) FN1A=' ' FN1I=' ' READ(LUN,*) FN1A,FN1I C NUMBER OF OUTPUT FILES TO BE OPEN IF(STORE.EQ.0.) THEN NF1=0 ELSE NF1=1 END IF C C READING STRINGS COMPOSING THE NAMES OF OUTPUT FILES (CRT.5.5.2) FN2A=' ' FN2I=' ' DO 21 I=1,MF FNB(I)=' ' 21 CONTINUE READ(LUN,*) FN2A,FN2I,(FNB(I),I=1,MF) C NUMBER OF OUTPUT FILES TO BE OPEN NF2=NSTOR IF(2*(NF1+NF2).GT.NUW) THEN PAUSE 'ERROR 554 IN WRIT1: FEW LOGICAL UNITS AVAILABLE' STOP END IF C C READING STRINGS COMPOSING THE NAMES OF OUTPUT FILES (CRT.5.5.3) FN3A=' ' FN3I=' ' DO 31 I=NF2+1,MF FNB(I)=' ' 31 CONTINUE READ(LUN,*) FN3A,FN3I,(FNB(I),I=NF2+1,MF) C NUMBER OF OUTPUT FILES TO BE OPEN IF(MODCRT.LE.1) THEN MF3=0 ELSE DO 32 I=NF2+1,MF IF(FNB(I).EQ.' ') THEN MF3=I-1-NF2 GO TO 33 END IF 32 CONTINUE MF3=MF-NF2 33 CONTINUE END IF C ELSE C C NUMBERS OF INITIAL RAY ELEMENTS ALONG WHICH NOTHING IS STORED IF(MODCRT.EQ.0) THEN KWRIT1=0 ELSE KWRIT1=NELEM(IKODE) END IF KWRIT2=KWRIT1 IF(MODCRT.LE.1) THEN KWRIT3=999999 ELSE KWRIT3=NELEM(IKODE) END IF C C READING STRINGS COMPOSING THE NAMES OF OUTPUT FILES DO 41 I=JWAVE+1,IWAVE-1 READ(LUN,*,END=98) FN1C,FN2C,FN3C,(FN2D(J),J=1,MF) 41 CONTINUE FN1C=' ' FN2C=' ' FN3C=' ' DO 42 I=1,MF FN2D(I)=' ' 42 CONTINUE READ(LUN,*,END=98) FN1C,FN2C,FN3C,(FN2D(I),I=1,MF) C C OPENING THE OUTPUT FILES (CRT.5.5.1) IF(NF1.NE.0.) THEN NAME1(1)=FN1A NAME1(2)=FN1C CALL FNAME(2,NAME1,NAME2(1)) IF(NAME2(1).NE.' ') THEN OPEN(LUW(1),FILE=NAME2(1),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=1 J=1 GO TO 91 END IF END IF NAME1(1)=FN1I CALL FNAME(2,NAME1,NAME2(2)) IF(NAME2(2).NE.' ') THEN OPEN(LUW(2),FILE=NAME2(2),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=4 J=2 GO TO 91 END IF END IF END IF C C OPENING THE OUTPUT FILES (CRT.5.5.2) DO 44 I=1,NF2 NAME1(1)=FN2A NAME1(2)=FNB(I) NAME1(3)=FN2C NAME1(4)=FN2D(I) IF(NAME1(2).EQ.' '.AND.NAME1(3).EQ.' '.AND.NAME1(4).EQ.' ') * THEN NAME1(1)=' ' END IF J=2*(NF1+I)-1 CALL FNAME(4,NAME1,NAME2(J)) IF(NAME2(J).NE.' ') THEN OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=2 GO TO 91 END IF END IF NAME1(1)=FN2I IF(NAME1(2).EQ.' '.AND.NAME1(3).EQ.' '.AND.NAME1(4).EQ.' ') * THEN NAME1(1)=' ' END IF J=2*(NF1+I) CALL FNAME(4,NAME1,NAME2(J)) IF(NAME2(J).NE.' ') THEN OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=5 GO TO 91 END IF END IF 44 CONTINUE C C OPENING THE OUTPUT FILES (CRT.5.5.3) NF3=0 IF(MODCRT.GE.2) THEN IF(FN3C.EQ.' ') THEN PAUSE 'ERROR 557 IN WRIT1: FEW FILENAMES SPECIFIED' STOP ELSE NKODE=NELEM(LCODE()) C NKODE IS THE NUMBER OF RAY ELEMENTS IF(MODCRT.GE.3) NKODE=MIN0(KWRIT3+1,NKODE) C NKODE IS THE INDEX OF THE LAST RAY ELEMENT TO BE STORED NF3=NKODE-KWRIT3 IF(NF3.GT.MF3) THEN PAUSE 'ERROR 556 IN WRIT1: FEW FILENAMES SPECIFIED' STOP ELSE IF(2*(NF1+NF2+NF3).GT.NUW) THEN PAUSE 'ERROR 554 IN WRIT1: FEW LOGICAL UNITS AVAILABLE' STOP END IF DO 45 I=1,NF3 NAME1(1)=FN3A NAME1(2)=FNB(KWRIT3+I) NAME1(3)=FN3C J=2*(NF1+NF2+I)-1 CALL FNAME(3,NAME1,NAME2(J)) IF(NAME2(J).NE.' ') THEN OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=5 GO TO 91 END IF END IF NAME1(1)=FN3I J=2*(NF1+NF2+I) CALL FNAME(3,NAME1,NAME2(J)) IF(NAME2(J).NE.' ') THEN OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1) IF(IE1.NE.0) THEN C OPEN FILE ERROR IE2=6 GO TO 91 END IF END IF 45 CONTINUE END IF END IF C C INITIAL VALUES FOR THE ELEMENTARY WAVE JRAY=0 JUEB=0 JFCT=0 JOUTP=0 JTRANS=0 DO 51 I=1,MENDR+2 NENDR(I)=0 51 CONTINUE DO 52 I=1,2*(NF1+NF2+NF3) JPOINT(I)=0 52 CONTINUE C C WRITING TO THE OUTPUT LOG FILE WRITE(LULOG,81) IWAVE 81 FORMAT(' WAVE',I5,':') C END IF C C INDEX OF THE LAST WAVE: JWAVE=IWAVE C C SCREEN OUTPUT CALL SCRO1(IWAVE) RETURN C 91 CONTINUE WRITE(*,'('' STATUS'',I6,''.'',I1,'': '',A)') IE1,IE2,NAME2(J) PAUSE 'ERROR 551 IN WRIT1: OPEN FILE ERROR' STOP 98 CONTINUE PAUSE 'ERROR 558 IN WRIT1: END OF INPUT FILE' STOP END C C======================================================================= C SUBROUTINE WRIT2(LULOG,IRAY) INTEGER LULOG,IRAY C C THIS SUBROUTINE IS CALLED WHEN STARTING THE COMPLETE TRACING OF A NEW C RAY. C C INPUT: C LULOG...LOGICAL UNIT NUMBER OF THE LOG OUTPUT DEVICE. C IRAY... THE INDEX OF THE RAY WHICH WILL BE COMPUTED (I.E. THE C OUTPUT OF THE SUBROUTINE RPAR2 FROM THE FILE 'RPAR.FOR'). C C NO OUTPUT. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C JRAY IS REDEFINED IN THIS SUBROUTINE. NO OTHER OF THE STORAGE C LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL SCRO2 C SCRO2... FILE 'SCRO.FOR'. C C DATE: 1990, NOVEMBER 11 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER I C JRAY=IRAY DO 1 I=1,NF2 JSTOR(I)=0 1 CONTINUE C C SCREEN OUTPUT CALL SCRO2(IRAY) RETURN END C C======================================================================= C SUBROUTINE WRIT31(YL,Y,YY,IY) REAL YL(6),Y(35),YY(5) INTEGER IY(12) C C THIS SUBROUTINE STORES THE COMPUTED QUANTITIES ALONG A RAY (SEE C C.R.T.5.5.1). IT IS CALLED WITH CONSTANT STEP STORE OF THE C INDEPENDENT VARIABLE ALONG THE RAY, AND AT THE POINTS OF INTERSECTION C WITH INTERFACES EITHER BEFORE AND AFTER THE TRANSFORMATION. C C INPUT: C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY. C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY. C YY... ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG C THE RAY. C IY... ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED C ALONG THE RAY. C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C NO OUTPUT. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C ARRAY JPOINT IS MODIFIED IN THIS SUBROUTINE. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL NELEM,SCRO3 INTEGER NELEM C NELEM... FILE 'CODE.FOR'. C SCRO3... FILE 'SCRO.FOR'. C C DATE: 1992, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER I C IF(NELEM(IY(2)).GT.KWRIT1) THEN IF(NAME2(1).NE.' ') THEN WRITE(LUW(1)) * JWAVE,JRAY,IY(1),IY(5),IY(6),YY(1),YL,(Y(I),I=1,IY(1)) END IF JPOINT(1)=JPOINT(1)+1 END IF C C SCREEN OUTPUT CALL SCRO3(YL,Y,YY,IY) RETURN END C C======================================================================= C SUBROUTINE WRIT32(ISTOR,YL,Y,YY,IY,NAMPL,YC) INTEGER ISTOR,IY(12),NAMPL REAL YL(6),Y(27),YY(5),YC(NAMPL) C C THIS SUBROUTINE STORES THE COMPUTED QUANTITIES AT SPECIFIED SURFACES C (SEE C.R.T.5.5.2). IT IS CALLED AT THE POINTS OF INTERSECTION OF THE C RAY WITH SPECIFIED SURFACES. C C INPUT: C ISTOR...THE SEQUENTIAL NUMBER IN THE INPUT DATA OF THE SPECIFIED C SURFACE. C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY. C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY. C QUANTITIES Y(28) TO Y(IY(1)) REPRESENTING REDUCED C AMPLITUDES ARE IGNORED. C YY... ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG C THE RAY. C IY... ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED C ALONG THE RAY. C NAMPL...NUMBER OF REAL QUANTITIES REPRESENTING COMPLEX-VALUED C VECTORIAL REDUCED AMPLITUDES. IF NO CONVERSION C COEFFICIENTS ARE APPLIED NAMPL=IY(1)-27, OTHERWISE C NAMPL=6 OR 12 (SEE C.R.T.5.5.4). C YC... ARRAY CONTAINING REAL QUANTITIES REPRESENTING COMPLEX- C -VALUED VECTORIAL REDUCED AMPLITUDES. IF NO CONVERSION C COEFFICIENTS ARE APPLIED, YC IS A COPY OF Y(28) TO C Y(IY(1)). OTHERWISE, YC REPRESENTS THE VECTORIAL REDUCED C AMPLITUDES INVOLVING APPROPRIATE CONVERSION COEFFICIENTS, C EXPRESSED IN RAY-CENTRED COORDINATE SYSTEM (SEE C C.R.T.5.5.4): C P WAVE AT THE INITIAL POINT OF THE RAY: C NAMPL=6, C YC(1)=REAL(A13), YC(2)=AIMAG(A13), C YC(3)=REAL(A23), YC(4)=AIMAG(A23), C YC(5)=REAL(A33), YC(6)=AIMAG(A33). C S WAVE AT THE INITIAL POINT OF THE RAY: C NAMPL=12, C YC(1)=REAL(A11), YC(2)=AIMAG(A11), C YC(3)=REAL(A21), YC(4)=AIMAG(A21), C YC(5)=REAL(A31), YC(6)=AIMAG(A31), C YC(7)=REAL(A12), YC(8)=AIMAG(A12), C YC(9)=REAL(A22), YC(10)=AIMAG(A22), C YC(11)=REAL(A32), YC(12)=AIMAG(A32). C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C NO OUTPUT. C C COMMON BLOCK /DCRT/ (SEE SUBROUTINE FILE 'RAY.FOR'): INTEGER MEND,MSTOR PARAMETER (MEND=128) PARAMETER (MSTOR=128) INTEGER KSTORE,NEXPS,NHLF,MODCRT REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7) INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR) COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH, * UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C ARRAY JPOINT IS MODIFIED IN THIS SUBROUTINE. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL NELEM INTEGER NELEM C NELEM...FILE 'CODE.FOR'. C C DATE: 1992, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER NY C JSTOR(ISTOR)=JSTOR(ISTOR)+1 IF(KSTOR(NSTOR+ISTOR).LE.JSTOR(ISTOR) * .AND.JSTOR(ISTOR).LE.KSTOR(2*NSTOR+ISTOR)) THEN IF(NELEM(IY(2)).GT.KWRIT2) THEN NY=27+NAMPL IF(NAME2(2*(NF1+ISTOR)-1).NE.' ') THEN WRITE(LUW(2*(NF1+ISTOR)-1)) * JWAVE,JRAY,NY,IY(5),IY(6),YY(1),YL,Y,YC END IF JPOINT(2*(NF1+ISTOR)-1)=JPOINT(2*(NF1+ISTOR)-1)+1 END IF END IF RETURN END C C======================================================================= C SUBROUTINE WRIT33(YL,Y,YY,IY) REAL YL(6),Y(35),YY(5) INTEGER IY(12) C C THIS SUBROUTINE STORES THE COMPUTED QUANTITIES AT THE ENDPOINTS OF THE C INDIVIDUAL ELEMENTARY WAVES (SEE C.R.T.5.5.3). IT IS CALLED AT THE C ENDPOINTS OF THE ELEMENTS OF RAYS, SITUATED AT STRUCTURAL INTERFACES. C C INPUT: C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY. C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY. C YY... ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG C THE RAY. C IY... ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED C ALONG THE RAY. C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C NO OUTPUT. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL NELEM INTEGER NELEM C NELEM...FILE 'CODE.FOR'. C C DATE: 1992, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATION: INTEGER I C I=NELEM(IY(2))-KWRIT3 IF(1.LE.I.AND.I.LE.NF3) THEN IF(NAME2(2*(NF1+NF2+I)-1).NE.' ') THEN WRITE(LUW(2*(NF1+NF2+I)-1)) JRAY,IY,YL,(Y(I),I=1,IY(1)),YY END IF JPOINT(2*(NF1+NF2+I)-1)=JPOINT(2*(NF1+NF2+I)-1)+1 END IF RETURN END C C======================================================================= C SUBROUTINE WRIT4(LULOG,IRAY,YL,Y,YY,IY,IEND,ISHEET) C INTEGER LULOG,IRAY,IY(12),IEND,ISHEET REAL YL(6),Y(35),YY(5) C C THIS SUBROUTINE STORES THE QUANTITIES AT THE INITIAL POINT OF THE RAY C (SEE C.R.T.6.1). IT IS CALLED AFTER TERMINATION OF TRACING THE RAY. C C INPUT: C LULOG...LOGICAL UNIT NUMBER OF THE LOG OUTPUT DEVICE. C IRAY... THE INDEX OF THE RAY WHICH HAS BEEN COMPUTED (I.E. THE C OUTPUT OF THE SUBROUTINE RPAR2 FROM THE FILE 'RPAR.FOR'). C YL... ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY. C Y... ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY. C YY... ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG C THE RAY. C IY... ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED C ALONG THE RAY. C IEND... REASON OF THE TERMINATION OF THE COMPUTATION OF A RAY (SEE C C.R.T.5.4). FOR A DETAILED DESCRIPTION SEE SUBROUTINES C RAY2 (FILE 'RAY.FOR') AND INIT2 (FILE 'INIT.FOR'). C ISHEET..RAY-HISTORY INDEX. THE DIFFERENT RAY HISTORIES ARE C CONSECUTIVELY INDEXED BY POSITIVE INTEGERS 1,2,3,... C ACCORDING TO THEIR APPEARANCE DURING RAY TRACING. C THE RAY HISTORIES ARE INDEXED INDEPENDENTLY WITHIN EACH C ELEMENTARY WAVE. C THE RAY-HISTORY INDICES ARE COMPLEMENTED WITH SIGN: C POSITIVE - SUCCESSFUL RAY (CROSSING REFERENCE SURFACE), C NEGATIVE - UNSUCCESSFUL RAY (TERMINATING BEFORE CROSSING C REFERENCE SURFACE). C C NO OUTPUT. C C COMMON BLOCK /DCRT/ (SEE SUBROUTINE FILE 'RAY.FOR'): INTEGER MEND,MSTOR PARAMETER (MEND=128) PARAMETER (MSTOR=128) INTEGER KSTORE,NEXPS,NHLF,MODCRT REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7) INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR) COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH, * UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C COMMON BLOCK /INITC/ (SEE SUBROUTINE FILE 'INIT.FOR'): INTEGER MSRFCA PARAMETER (MSRFCA=128) INTEGER ISB1I,ICB1I REAL YLI(6),YI(25),FSRFCA(MSRFCA) COMMON/INITC/ISB1I,ICB1I,YLI,YI,FSRFCA C NONE OF THE STORAGE LOCATIONS ARE ALTERED. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C JUEB, JFCT, JOUTP, JTRANS, ARRAYS JPOINT AND NENDR ARE MODIFIED IN C THIS SUBROUTINE. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL SCRO4,CHECK C SCRO4... FILE 'SCRO.FOR'. C CHECK... THIS FILE. C C DATE: 1994, JANUARY 23 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER I,I0,I1,I2,I3,I4,I5,I6,I7,I8,I9 REAL S12,S13,S23,S14,S24,S34 C C WRITING THE QUANTITIES AT THE INITIAL POINT OF THE RAY (C.R.T.6.1) I1=-JWAVE DO 10 I=1,NF1+NF2+NF3 IF(NAME2(2*I).NE.' ') THEN WRITE(LUW(2*I)) I1,IRAY,ICB1I,IEND,ISHEET,YLI,YI END IF JPOINT(2*I)=JPOINT(2*I)+1 10 CONTINUE C C STATISTICS JFCT=JFCT+IY(9) JOUTP=JOUTP+IY(10) JTRANS=JTRANS+IY(11) DO 21 I=1,MENDR IF(IEND.EQ.JENDR(I)) THEN NENDR(I)=NENDR(I)+1 GO TO 22 END IF 21 CONTINUE NENDR(MENDR+1)=NENDR(MENDR+1)+1 22 CONTINUE NENDR(MENDR+2)=NENDR(MENDR+2)+1 C C WRITING TO THE OUTPUT LOG FILE C SIMPLECTICITY OF THE PROPAGATOR MATRIX (SEE C.R.T.5.6L) S12=Y(12)*Y(18)+Y(13)*Y(19)-Y(14)*Y(16)-Y(15)*Y(17) S13=Y(12)*Y(22)+Y(13)*Y(23)-Y(14)*Y(20)-Y(15)*Y(21)-1. S23=Y(16)*Y(22)+Y(17)*Y(23)-Y(18)*Y(20)-Y(19)*Y(21) S14=Y(12)*Y(26)+Y(13)*Y(27)-Y(14)*Y(24)-Y(15)*Y(25) S24=Y(16)*Y(26)+Y(17)*Y(27)-Y(18)*Y(24)-Y(19)*Y(25)-1. S34=Y(20)*Y(26)+Y(21)*Y(27)-Y(22)*Y(24)-Y(23)*Y(25) C CHECKING EXCEEDING THE SPECIFIED LIMITS I=0 CALL CHECK(YY(2),UEB,I0,I) CALL CHECK(YY(3),UEBPP,I1,I) CALL CHECK(YY(4),UEBPH,I2,I) CALL CHECK(YY(5),UEBHH,I3,I) CALL CHECK(S12,UEBDRT,I4,I) CALL CHECK(S13,UEBDRT,I5,I) CALL CHECK(S23,UEBDRT,I6,I) CALL CHECK(S14,UEBDRT,I7,I) CALL CHECK(S24,UEBDRT,I8,I) CALL CHECK(S34,UEBDRT,I9,I) C I IS THE NUMBER OF CHECKED QUANTITIES EXCEEDING THEIR SPECIFIED C UPPER LIMITS IF(I.GT.0) THEN C WRITING REPORT ON THIS RAY IF(JUEB.EQ.0) THEN WRITE(LULOG,31) 31 FORMAT(7X,'RAY:',5X, * 'CHECKED QUANTITIES IN PERCENTS OF THEIR SPECIFIED LIMITS') END IF JUEB=JUEB+1 WRITE(LULOG,32) IRAY,I0,I1,I2,I3,I4,I5,I6,I7,I8,I9 32 FORMAT( I10,': ',10I6) END IF C C SCREEN OUTPUT CALL SCRO4(IRAY,YL,Y,YY,IY,IEND,ISHEET) RETURN END C C----------------------------------------------------------------------- C SUBROUTINE CHECK(Q,QUEB,IRATE,I) REAL Q,QUEB INTEGER IRATE,I C C AUXILIARY SUBROUTINE TO WRIT4 C IF(QUEB.GT.0.) THEN IRATE=INT(100.*Q/QUEB+0.5) ELSE IRATE=0 END IF IF(ABS(Q).GT.QUEB) THEN I=I+1 END IF RETURN END C C======================================================================= C SUBROUTINE WRIT5(LULOG,IWAVE) INTEGER LULOG,IWAVE C C THIS SUBROUTINE IS CALLED AFTER TERMINATION OF THE COMPUTATION OF AN C ELEMENTARY WAVE, AND WHEN TERMINATING THE COMPLETE RAY TRACING C PROGRAM. C C INPUT: C LULOG...LOGICAL UNIT NUMBER OF THE LOG OUTPUT DEVICE. C IWAVE...ZERO WHEN TERMINATING THE COMPLETE RAY TRACING PROGRAM, C OTHERWISE THE INDEX OF THE ELEMENTARY WAVE WHICH HAS BEEN C COMPUTED (I.E. THE OUTPUT OF THE SUBROUTINE CODE1 FROM THE C FILE 'CODE.FOR'). C C NO OUTPUT. C C COMMON BLOCKS /WRITC/ AND /WRITN/: INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR PARAMETER (NUW=16) PARAMETER (MENDR=17) INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW) INTEGER JENDR(MENDR),NENDR(MENDR+2) COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2, * KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR CHARACTER*16 NAME2(NUW) COMMON/WRITN/NAME2 C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED. C C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED: EXTERNAL SCRO5 C SCRO5... FILE 'SCRO.FOR'. C C DATE: 1992, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER I,J,N,K(4) C C WRITING TO THE OUTPUT LOG FILE: IF(IWAVE.NE.0) THEN IF(JUEB.GT.0) THEN WRITE(LULOG,10) 10 FORMAT(11X,'ABOVE RAYS ARE COMPUTED WITH DECREASED ACCURACY') END IF C REASONS OF TERMINATION OF TRACING RAYS WRITE(LULOG,21) NENDR(MENDR+2),JFCT,JOUTP,JTRANS N=0 DO 12 J=1,MENDR IF(NENDR(J).GT.0) THEN N=N+1 K(N)=J END IF IF(N.EQ.4.OR.(J.EQ.MENDR.AND.N.GT.0)) THEN WRITE(LULOG,22) (NENDR(K(I)),JENDR(K(I)),I=1,N) N=0 END IF 12 CONTINUE IF(NENDR(MENDR+1).NE.0) THEN WRITE(LULOG,23) NENDR(MENDR+1) END IF C LIST OF OUTPUT FILES DO 14 I=1,2*(NF1+NF2+NF3) IF(NAME2(I).NE.' ') THEN WRITE(LULOG,24) JPOINT(I),NAME2(I) END IF 14 CONTINUE C FORMATS 21 FORMAT( I10,' RAYS ',I12,' FCT ',I12,' STEPS',I12,' TRANS') 22 FORMAT(4(I10,' IEND=',I2)) 23 FORMAT( I10,' IEND=OTHER') 24 FORMAT( I10,' POINTS IN FILE: ',A) END IF C C SCREEN OUTPUT: CALL SCRO5(IWAVE) RETURN END C C======================================================================= C SUBROUTINE FNAME(NUM1,NAME1,NAME2) INTEGER NUM1 CHARACTER*(*) NAME1(NUM1) CHARACTER*(*) NAME2 C C THIS SUBROUTINE IS DESIGNED TO ANALYSE THE SPECIFIED STRINGS AND TO C COMPOSE THE FILENAME OF THEM. C C INPUT: C NAME1...CHARACTER ARRAY OF CHARACTER STRINGS TO BE ANALYSED. C NUM1... NUMBER OF FILENAMES TO BE ANALYSED. C C OUTPUT: C NAME2...FILENAME COMPOSED OF THE ANALYSED INPUT COMPONENTS C (STRINGS). C C NO SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED. C C ERROR MESSAGES: C 559... TOO MANY STRINGS: C THE NUMBER NUM1 OF INPUT STRINGS EXCEEDS THE DIMENSION M1 C OF ARRAYS J1 AND L1. PARAMETER M1 MUST BE INCREASED. C C DATE: 1992, DECEMBER 18 C CODED BY LUDEK KLIMES C C----------------------------------------------------------------------- C C AUXILIARY STORAGE LOCATIONS: INTEGER M1 PARAMETER (M1=4) INTEGER J1(M1),L1(M1),I1,J2,L2,I2,N,I C C M1... MAXIMUM NUMBER OF ANALYSED STRINGS. C J1(N)...NUMBER OF THE CURRENTLY ANALYSED CHARACTERS OF NAME1(N), C I.E. THE POSITION OF THE SPACE AFTER THE LAST ANALYSED C WORD OF NAME1(N). A WORD IS A SUBSTRING BETWEEN TWO C CONSECUTIVE SPACES. C L1(N)...LENGTH OF NAME1(N). C I1... BEGINNING OF THE LAST ANALYSED WORD OF NAME1(N), I.E. THE C PREVIOUS VALUE OF J1(N) INCREASED BY 1. C J2... NUMBER OF THE CURRENTLY DEFINED CHARACTERS OF NAME2. C L2... LENGTH OF NAME2. C I2... AUXILIARY VARIABLE - PREVIOUS VALUE OF J2 INCREASED BY 1. C N... LOOP VARIABLE - INDEX OF INPUT FILENAME. C I... LOOP VARIABLE - POSITION IN A STRING. C C....................................................................... C IF(M1.LT.NUM1) THEN PAUSE 'ERROR 559 IN FNAME: TOO MANY STRINGS' STOP END IF DO 11 N=1,NUM1 J1(N)=0 L1(N)=LEN(NAME1(N)) 11 CONTINUE J2=0 L2=LEN(NAME2) C 20 CONTINUE DO 29 N=1,NUM1 C (A) ANALYSING NAME1(N): I1=J1(N)+1 DO 21 I=I1,L1(N) IF(NAME1(N)(I:I).EQ.' ') THEN J1(N)=I GO TO 22 END IF 21 CONTINUE J1(N)=L1(N)+1 22 CONTINUE C J1(N)-TH CHARACTER OF NAME1(N) IS FOUND TO BE BLANK. C (B) COPYING THE WORD FROM NAME1(N) TO NAME2: IF(J1(N).GT.I1) THEN I2=J2+1 J2=MIN0(J2+J1(N)-I1,L2) NAME2(I2:J2)=NAME1(N)(I1:J1(N)-1) END IF 29 CONTINUE C DO 31 N=1,NUM1 IF(J1(N).LT.L1(N)) GO TO 20 31 CONTINUE DO 32 I=J2+1,L2 NAME2(I:I)=' ' 32 CONTINUE RETURN END C C======================================================================= C