source: trunk/src/seismic_processing/hyp2000/hystl.for @ 3172

Revision 3172, 10.9 KB checked in by paulf, 13 years ago (diff)

changes for g77

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1      SUBROUTINE HYSTL
2C--CALLED BY HYPOINV TO LIST STATIONS & CRUST MODEL ON PRINT FILE.
3      CHARACTER COMSTR*10,CURTIM*28, TYPSTR*3
4      INCLUDE 'common.inc'
5      DIMENSION PD(20)
6      SAVE PD
7      DATA PD /20*0./
8
9C--CONTINUE ONLY IF STATIONS & OTHER DATA ARE TO BE PRINTED
10      IF (.NOT.LPRT .OR. JST.EQ.0) RETURN
11
12C--PRINT CURRENT DATE & TIME FIRST
13      CALL HYTIME (CURTIM)
14      WRITE (15,1000) GREETING, CURTIM,RUNLAB, CDOMAN,CPVERS
151000  FORMAT (' HYPOINVERSE 2000'/1X,A/' RUN ON ',A28,
16     2 '  RUN LABEL=',A1/' PROCESSING DOMAIN=',A2,
17     3 '  PROCESSING VERSION=',A2/)
18      IF (JST.LT.2) GOTO 18
19
20      IF (JST2.LT.1) GOTO 210
21C--LIST THE BASIC STATION DATA
22      M=MAXMOD
23      IF (M.GT.2) M=2
24      WRITE (15,1025) (CRODE(I),I=1,M)
251025  FORMAT (' STATIONS:',36X,A3,66X,A3)
26      WRITE (15,1009)
271009  FORMAT (6X,'NAME NT COM LC CR  --LAT---  ---LON--- PDLY1 A',
28     3 '  FCOR FWT FMC.EXPIRE  XCOR XWT PSWT  CAL ',
29     2 ' CAL.EXPIRE PER TYP PDLY2')
30
31C--LOOP TO DECODE PARAMETERS AND WRITE STATIONS
32      DO 5 J=1,JSTA
33        XLTM=ABS(JLATM(J)*.01)
34        XLNM=ABS(JLONM(J)*.01)
35        XMC=JXCOR(J)*.01
36        FMC=JFCOR(J)*.01
37        DO I=1,M
38          PD(I)=.01*JPD(I,J)
39        END DO
40        IF (JLMOD(J)) THEN
41          CTEMP='A'
42        ELSE
43          CTEMP=' '
44        END IF
45        PWT=.1*JPSWT(J)
46        XWT=JXWT(J)*.1
47        CWT=JFWT(J)*.1
48        PER=JPER(J)*.1
49        CAL=JCAL(J)*.001
50        KTEMP=ABS(JLATD(J))
51        KTEMP2=ABS(JLOND(J))
52        IE=' '
53        IS=' '
54        IF (KTEMP.LT.0 .OR. XLTM.LT.0.) IS='S'
55        IF (KTEMP2.LT.0 .OR. XLNM.LT.0.) IE='E'
56
57C--OUTPUT ONE LINE FOR THIS STATION
58C--CHOOSE MAIN OR EQUIVALENT LOCATION CODE
59        WRITE (15,1001)
60     2  J,STANAM(J),JNET(J), JCOMP3(J),JSLOC(J),JCOMP1(J),
61     2  STRMK(J),KTEMP,IS,XLTM, KTEMP2,IE,XLNM, PD(1),CTEMP,FMC,
62     3  CWT,JFEXP(J),XMC,XWT,PWT, CAL,JCEXP(J),
63     4  PER,JTYPE(J),(PD(I),I=2,M)
64     
651001    FORMAT (1X,I4,1X,A5,A2,1X, A3,1X,A2,1X,A1,
66     2  A1,I4,A1,F5.2, I5,A1,F5.2, F6.2,1X,A1,F6.2,
67     3  F4.1,I11,F6.2,F4.1,F5.2, F6.2,I11,
68     4  F4.1,I3,1X,5F6.2)
69
705     CONTINUE
71
72      IF (JST2.LT.2) GOTO 210
73C--PRINT THE DELAYS FOR ALL MODELS IF THERE IS MORE THAN 1
74      IF (MAXMOD.GT.1) THEN
75        M=MAXMOD
76        IF (M.GT.20) M=20
77        WRITE (15,1026) (CRODE(I),I=1,M)
781026    FORMAT (/21X,20(3X,A3))
79        WRITE (15,1017) (I,I=1,M)
801017    FORMAT(6X,'NAME NT COM C LC', 9(:,'  DLY',I1), 11(:,' DLY',I2))
81        DO J=1,JSTA
82          DO I=1,M
83            PD(I)=.01*JPD(I,J)
84          END DO
85          WRITE (15,1018) J,STANAM(J),JNET(J),
86     2    JCOMP3(J),JCOMP1(J),JSLOC(J), (PD(I),I=1,M)
871018      FORMAT (1X,I4,1X,A5,A2,1X, A3,1X,A1,1X,A2, 20F6.2)
88        END DO
89      END IF
90
91      IF (MAXMOD.GT.20) THEN
92        M=MAXMOD
93        IF (M.GT.40) M=40
94        WRITE (15,1026) (CRODE(I),I=21,M)
95        WRITE (15,1027) (I,I=21,M)
961027    FORMAT (6X,'NAME NT COM C LC', 20(:,' DLY',I2))
97        DO J=1,JSTA
98          DO I=1,M-20
99            PD(I)=.01*JPD(I+20,J)
100          END DO
101          WRITE (15,1018) J,STANAM(J),JNET(J),
102     2    JCOMP3(J),JCOMP1(J),JSLOC(J), (PD(I),I=1,M-20)
103        END DO
104      END IF
105
106210   IF (JST3.LT.1) GOTO 18
107C--PRINT THE CRUSTAL MODELS, ONE AT A TIME
108      DO 15 I=1,MAXMOD
109      IF (MODTYP(I).EQ.-1) GOTO 15
110      WRITE (15,1002) I,MODNAM(I)
1111002  FORMAT (/' CRUST MODEL',I3,': ',A/)
112
113C--LIST THE APPLICABLE REGIONS (NODES) IF MULTIPLE MODELS ARE IN USE
114      IF (LMULT) THEN
115        IF (I.EQ.MODDEF) THEN
116          WRITE (15,1012)
1171012      FORMAT (' THIS IS THE DEFAULT MODEL FOR UNASSIGNED REGIONS')
118        ELSE
119
120          WRITE (15,1024)
1211024      FORMAT (' THE CIRCULAR REGIONS (NODES) DEFINED FOR THIS ',
122     2    'MODEL ARE:'/' NODE  CENTER-LAT  CENTER-LON  MOD  ',
123     3    'INNER-RADIUS  RING-WIDTH  OUTER-RADIUS')
124          DO IZ=1,NNODE
125            IF (I.EQ.MODH(IZ)) WRITE (15,1019) IZ,HLAT(IZ),HLON(IZ),
126     2      MODH(IZ),RAD1(IZ),DRAD(IZ),RAD2(IZ)
1271019        FORMAT (I4,F11.4,F13.4,I5,F11.2,2F13.2)
128          END DO
129        END IF
130
131        WRITE (15,1013)
1321013    FORMAT (1X)
133      END IF
134
135C--SIGNAL IF THIS MODEL HAS AN ALTERNATE MODEL
136      IF (MODALT(I).GT.0) WRITE (15,1016) MODALT(I),CRODE(MODALT(I))
1371016  FORMAT (' SOME STATIONS USE MODEL',I3,' (',A3,
138     2 ') INSTEAD OF THIS ONE.')
139
140C--PRINT THE LAYER PARAMETERS FOR THE MODEL
141C--HANDLE HOMOGENEOUS LAYER & LINEAR GRADIENT MODELS SEPERATELY
142      IF (MODTYP(I).EQ.0) THEN
143        WRITE (15,1003)
1441003    FORMAT (' LINEAR GRADIENT MODEL WITH VELOCITIES SPECIFIED AT',
145     2  ' THE FOLLOWING DEPTHS:')
146      ELSE
147        WRITE (15,1004)
1481004    FORMAT (' HOMOGENEOUS LAYER MODEL WITH THE FOLLOWING',
149     2  ' VELOCITIES AND LAYER TOPS:')
150      END IF
151      WRITE (15,1005)
1521005  FORMAT (4X,'VELOCITY  DEPTH')
153      DO 10 J=1,LAY(I)
15410    WRITE (15,1006) J,VEL(J,I),D(J,I)
1551006  FORMAT (I3,2F8.3)
15615    CONTINUE
157
158C--PRINT THE COMPUTATIONAL PARAMETERS FOR THIS RUN
15918    WRITE (15,1007)
1601007  FORMAT (/' TEST PARAMETERS:'/'   -ITERATION AND CONVERGENCE-',
161     2 5X,'-WEIGHTING AND ERRORS-     -MISCELLANEOUS-')
162
163      WRITE (15,1008) ITRLIM,DAMP,DISCUT,RMSCUT,MINSTA,
164     2 DQUIT,DRQT,DISW1,RMSW1,NET,
165     3 DXFIX,EIGTOL,DISW2,RMSW2,
166     4 DZMAX,RBACK,ITRDIS,ITRRES,ZTR,
167     5 DZAIR,BACFAC,SWT,RDERR,POS,
168     6 ERCOF
1691008  FORMAT (
170     1  I9,'=ITRLIM',F8.3,'=DAMP  ',F8.3,'=DISCUT',F8.3,'=RMSCUT',
171     1  I8,'=MINSTA'/
172     2 F9.3,'=DQUIT ',F8.3,'=DRQT  ',F8.3,'=DISW1 ',F8.3,'=RMSW1 ',
173     2  I8,'=NET'/
174     3 F9.3,'=DXFIX ',F8.3,'=EIGTOL',F8.3,'=DISW2 ',F8.3,'=RMSW2 '/
175     4 F9.3,'=DZMAX ',F8.3,'=RBACK ',  I8,'=ITRDIS',  I8,'=ITRRES',
176     4 F8.3,'=ZTR'/
177     5 F9.3,'=DZAIR ',F8.3,'=BACFAC',F8.3,'=SWT   ',F8.3,'=RDERR ',
178     5 F8.3,'=POS'/
179     6 46X,                                        F8.3,'=ERCOF')
180
181      WRITE (15,1014)
1821014  FORMAT (/6X,'------DURATION MAG CONSTANTS------',7X
183     2 ,'-DELAYS & MISC-    -STATIONS-')
184
185      WRITE (15,1015) FMA1,FMA2, DMA0,LMULT,LATEN,
186     2 FMB1,  FMB2,  DMA1,  LCOWT,  NSTLET,
187     3 FMZ1,  FMZ2,  DMA2,  LJUNK,  NETLET,
188     4 FMD1,  FMD2,  DMZ,            NCOMP,
189     5 FMF1,  FMF2,  DMGN,
190     6 FMGN,  FMBRK, DMLI,
191     7 DCOFM1,DBRKM1,MLOGA0,
192     7 DCOFM2,DBRKM2,
193     8 ZCOFM, ZBRKM
1941015  FORMAT (
195     1 F9.3,'=FMA1  ',F8.3,'=FMA2  ',F8.4,'=DMA0  ',  L8,'=LMULT ',
196     1   L8,'=ATTEN'/
197     2 F9.3,'=FMB1  ',F8.3,'=FMB2  ',F8.4,'=DMA1  ',  L8,'=CODAWT',
198     2   I8,'=SITE-LET'/
199     3 F9.3,'=FMZ1  ',F8.3,'=FMZ2  ',F8.4,'=DMA2  ',  L8,'=LJUNK ',
200     3   I8,'=NET-LET'/
201     4 F9.3,'=FMD1  ',F8.3,'=FMD2  ',F8.4,'=DMZ   ',  15X,
202     4   I8,'=COMP-LET'/
203     5 F9.3,'=FMF1  ',F8.3,'=FMF2  ',F8.4,'=DMGN  '/
204     6 F9.3,'=FMGN  ',F8.3,'=FMBRK ',F8.4,'=DMLIN '/
205     7 F9.4,'=DCOF1 ',F8.3,'=DBRK1 ',  I8,'=LOGA0 '/
206     7 F9.4,'=DCOF2 ',F8.3,'=DBRK2 '/
207     8 F9.4,'=ZCOF  ',F8.3,'=ZBRK  ')
208
209C--WRITE FMAG & XMAG COMPONENT CORRECTIONS
210      IF (NFCM.GT.0) WRITE (15,1077) (CFCM(I),AFCM(I),I=1,NFCM)
2111077  FORMAT(/'    DUR MAG COMPONENT CORRECTIONS:',10(2X,A3,'=',F4.2))
212      IF (NXCM.GT.0) WRITE (15,1078) (CXCM(I),AXCM(I),I=1,NXCM)
2131078  FORMAT ('    AMP MAG COMPONENT CORRECTIONS:',10(2X,A3,'=',F4.2))
214
215C--WRITE MAGNITUDE LABELS AND COMPONENTS
216C--FIRST FMAG
217      IF (NCPF1.EQ.0) THEN
218        COMSTR=' NO'
219      ELSE IF (NCPF1.LT.0) THEN
220        COMSTR='ALL'
221      ELSE
222        COMSTR='   '
223      END IF
224      WRITE (15,1040) LABF1,COMSTR, (COMPF1(I),I=1,NCPF1)
2251040  FORMAT (/'    --- MAGNITUDE LABELS & COMPONENTS ---'/
226     2 '    FMAG1: LABEL=',A1,2X,A3,' COMPS=',20(1X,A3))
227
228C--SECOND FMAG
229      IF (NCPF2.EQ.0) THEN
230        COMSTR=' NO'
231      ELSE IF (NCPF2.LT.0) THEN
232        COMSTR='ALL'
233      ELSE
234        COMSTR='   '
235      END IF
236      WRITE (15,1041) LABF2,COMSTR, (COMPF2(I),I=1,NCPF2)
2371041  FORMAT ('    FMAG2: LABEL=',A1,2X,A3,' COMPS=',20(1X,A3))
238
239C--FIRST XMAG
240C--CHOOSE BY COMPONENT
241      IF (LXCH) THEN
242        IF (NCPX1.EQ.0) THEN
243          COMSTR=' NO'
244        ELSE IF (NCPX1.LT.0) THEN
245          COMSTR='ALL'
246        ELSE
247          COMSTR='   '
248        END IF
249
250C--MAG TYPE
251        TYPSTR='ALL'
252        IF (MAG1TYPX.EQ.1) TYPSTR='ML '
253        IF (MAG1TYPX.EQ.2) TYPSTR='MX '
254
255        WRITE (15,1042) LABX1,COMSTR,TYPSTR, (COMPX1(I),I=1,NCPX1)
2561042    FORMAT ('    XMAG1: LABEL=',A1,2X,A3, '  TYPE=',A3,
257     2  '  COMPS=',20(1X,A3))
258
259C--CHOOSE BY INST TYPE
260      ELSE
261        IF (NXTYP1.EQ.0) THEN
262          COMSTR=' NO'
263        ELSE IF (NXTYP1.LT.0) THEN
264          COMSTR='ALL'
265        ELSE
266          COMSTR='   '
267        END IF
268        WRITE (15,1142) LABX1,COMSTR, (IXTYP1(I),I=1,NXTYP1)
2691142    FORMAT ('    XMAG1: LABEL=',A1,2X,A3,' INST TYPES=',3(1X,I1))
270      END IF
271
272C--SECOND XMAG
273C--CHOOSE BY COMPONENT
274      IF (LXCH) THEN
275        IF (NCPX2.EQ.0) THEN
276          COMSTR=' NO'
277        ELSE IF (NCPX2.LT.0) THEN
278          COMSTR='ALL'
279        ELSE
280          COMSTR='   '
281        END IF
282
283C--MAG TYPE
284        TYPSTR='ALL'
285        IF (MAG2TYPX.EQ.1) TYPSTR='ML '
286        IF (MAG2TYPX.EQ.2) TYPSTR='MX '
287
288        WRITE (15,1043) LABX2,COMSTR,TYPSTR, (COMPX2(I),I=1,NCPX2)
2891043    FORMAT ('    XMAG2: LABEL=',A1,2X,A3, '  TYPE=',A3,
290     2  '  COMPS=',20(1X,A3))
291
292C--CHOOSE BY INST TYPE
293      ELSE
294        IF (NXTYP2.EQ.0) THEN
295          COMSTR=' NO'
296        ELSE IF (NXTYP2.LT.0) THEN
297          COMSTR='ALL'
298        ELSE
299          COMSTR='   '
300        END IF
301        WRITE (15,1143) LABX2,COMSTR, (IXTYP2(I),I=1,NXTYP2)
3021143    FORMAT ('    XMAG2: LABEL=',A1,2X,A3,' INST TYPES=',3(1X,I1))
303      END IF
304
305      WRITE (15,1141) MAGSEL,MAGSL2
3061141  FORMAT ('    FMAG1 MAGSEL=',I1,'  FMAG2 MAGSEL=',I1)
307
308C--WRITE INPUT FILENAMES
309      WRITE (15,1020) INFILE(1),INFILE(2)
3101020  FORMAT (/' INPUT FILES:'/' COMMANDS:    ',A/14X,A)
311      IF (LBSTA) THEN
312        WRITE (15,'('' BINARY STATION SNAPSHOT FILE: '',A)') BSTAFL
313      ELSE
314        WRITE (15,'('' STATIONS:    '',A,''STATION FORMAT CODE='',I2)')
315     2  STAFIL,ISTFMT
316      END IF
317
318      WRITE (15,1021)DELFIL,ATNFIL,CALFIL,FMCFIL,XMCFIL,
319     2 PHSFIL,JCP,IH71T
3201021  FORMAT (
321     3 ' DELAYS:       ',A/
322     4 ' ATTENUATIONS: ',A/
323     5 ' CAL FACTORS:  ',A/
324     5 ' FMAG CORRECT: ',A/
325     6 ' XMAG CORRECT: ',A//
326     7 ' PHASES:       ',A/
327     8 8X,'PHASE FORMAT CODE=',I2,', TERMINATOR FORMAT CODE=',I1)
328
329      IF (LBCRU) THEN
330        WRITE (15,'('' BINARY CRUST SNAPSHOT FILE: '',A)') BCRUFL
331      ELSE
332        DO I=1,MAXMOD
333          IF (MODTYP(I).EQ.0) WRITE (15,1022) I,CRUFIL(I)
3341022      FORMAT (' LINEAR  GRADIENT  CRUST',I2,':  ',A)
335          IF (MODTYP(I).EQ.1) WRITE (15,1023) I,CRUFIL(I)
3361023      FORMAT (' HOMOGENEOUS LAYER CRUST',I2,':  ',A)
337        END DO
338      END IF
339
340C--WRITE OUTPUT FILENAMES
341      WRITE (15,1030) LAPP(1),PRTFIL
3421030  FORMAT (/' OUTPUT FILES: (T IF APPENDED TO)'/
343     2 ' (',L1,') PRINTOUT:    ',A)
344      IF (LSUM) WRITE (15,1031) LAPP(2),SUMFIL,IH71S
3451031  FORMAT (' (',L1,') SUMMARY:     ',A,'FORMAT CODE=',I1)
346      IF (LARC) WRITE (15,1032) LAPP(3),ARCFIL,JCA
3471032  FORMAT (' (',L1,') ARCHIVE:     ',A,'ARCHIVE FORMAT CODE=',I2)
348      IF (LMAG) WRITE (15,1036) MAGFIL
3491036  FORMAT (' MAGNITUDE DATA:  ',A)
350
351      WRITE (15,*)
352      RETURN
353      END
Note: See TracBrowser for help on using the repository browser.