Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

how compile this .for program ion windows seven 2

Status
Not open for further replies.
ppippus

ppippus

Programmer
Mar 20, 2012
8
IT
Hi for everyone

I have a problem to compile this program (attachement)
I have tried with g77 on windows seven but this compuiler does not work....
The platform indicated for this software (1971)are:
Platform: CDC, Scope, FTN4 (60 bit single precision)

can you help me to compile this program?

thanks

ppippus
 
Sort by date Sort by votes
So, do you know any fortran at all?
Have you tried to read the error messages and start cleaning up the program?
What kind of help are you exactly asking for?

I am getting error messages that need to be clean up. The program is very simple and short...it's just a matter of cleaning up the things are no longer done the way they used to and clean up the dirty things that they used to do...I notice they are using a single REAL array to store integer via a local array that is INTEGER...


 
Upvote 0 Downvote
A g77 compiler built for a CDC 7600 with 60 bit addressing won't work on an Intel based machine with 64 bit addressing. You need the proper compiler for that platform. Suggest you get gfortran for Windows.
 
Upvote 0 Downvote
Thanks for the help

If i use g77 the errors are:

Microsoft Windows XP [Versione 5.1.2600]
(C) Copyright 1985-2001 Microsoft Corp.


C:\>g77 LAYER.FOR
LAYER.FOR:1:
PROGRAM LAYER (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,TAPE1,TAPE2,
^
Invalid form for PROGRAM statement at (^)
LAYER.FOR: In subroutine `discrt':
LAYER.FOR:37: warning:
CALL DISCRT (A(N1),A(N2),A(N3),A(N4))
1
LAYER.FOR:86: (continued):
SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)
2
Argument #4 (named `nboun') of `discrt' is one type at (2) but is some other typ
e at (1) [info -f g77 M GLOBALS]
LAYER.FOR: In subroutine `stiff':
LAYER.FOR:40: warning:
CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)
1
LAYER.FOR:121: (continued):
SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N)
2
Argument #4 (named `nboun') of `stiff' is one type at (2) but is some other type
at (1) [info -f g77 M GLOBALS]
LAYER.FOR: In subroutine `solve':
LAYER.FOR:243:
IF(MP.EQ.1) PUNCH 2001, (G(K), K=1,NTOT)
1 2
Unrecognized statement name at (1) and invalid form for assignment or statement-
function definition at (2)
LAYER.FOR:48: warning:
CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,
1
LAYER.FOR:165: (continued):
SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR)
2
Argument #7 (named `maxb') of `solve' is one type at (2) but is some other type
at (1) [info -f g77 M GLOBALS]
LAYER.FOR: In subroutine `conv':
LAYER.FOR:449:
PUNCH 2001, STO
1 2
Unrecognized statement name at (1) and invalid form for assignment or statement-
function definition at (2)

C:\>

can gfortran on win seven (another pc that I have) resolve this problem..how can i change the code to compile it?


thanks
 
Upvote 0 Downvote
Trying to compile your program with gfortran I got these errors:
Code: 
$ gfortran layer.for -o layer
layer.for:1.13:

      PROGRAM LAYER (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,TAPE1,TAPE2, 
            1
Error: Invalid form of PROGRAM statement at (1)
layer.for:110.18:

      DHS=1.0E+100                                                      
                 1
Error: Real constant overflows its kind at (1)
layer.for:243.18:

      IF(MP.EQ.1) PUNCH 2001, (G(K), K=1,NTOT)                          
                 1
Error: Cannot assign to a named constant at (1)
layer.for:449.6:

      PUNCH 2001, STO                                                   
     1
Error: Unclassifiable statement at (1)
I changed the program so:
1. I deleted this from program header:
Code: 
(INPUT,OUTPUT,TAPE5=INPUT,... )
2. I changed the constant DHS to smaller value
Code: 
C     DHS=1.0E+100
      DHS=1.0E+38
3. I changed PUNCH to WRITE
Code: 
C     IF(MP.EQ.1) PUNCH 2001, (G(K), K=1,NTOT)
      IF(MP.EQ.1) WRITE(6,2001) (G(K), K=1,NTOT)
...
C     PUNCH 2001, STO
      WRITE(6,2001) STO
4. I commented out these lnes:
Code: 
C    .  20H PUNCH CODE         ,I5/
C    .  21H EQ 1 WGT.SEQ.PUNCHED   /
C    .  21H EQ 0 NOT PUNCHED       /
Now the program compiles, but I don't know what parameters to provide on input so that computes something...
Code: 
$ gfortran layer.for -o layer

$ layer
1 2 3 4 5 6 7
1 2 3 4 5 6
At line 27 of file layer.for (unit = 6, file = 'stdout')
Fortran runtime error: Expected REAL for item 17 in formatted transfer, got INTEGER
            22H DAMPING COEFF. (ALFA) ,F10.6/                                 22
                                       ^
1  2 3   5 6   7                                                         


 NUMBER OF MATERIALS  123
 SOLUTION CODE         45
 EQ 0 DECONVOLUTION 
 EQ 1 CONVOLUTION   
 PRINT CODE             6
 EQ 1 WGT.SEQ.PRINTED
 EQ 0 NOT PRINTED
 
Upvote 0 Downvote
The commenting out the lines in point 4 need not be done. I compiles too.
 
Upvote 0 Downvote
Thank you very very much mikrom...

Yuo are great!!!!

thanks

 
Upvote 0 Downvote
Hi ppus,
btw I tried other cmpilers too:

g77 compiles the modified code too: it writes som warnings but the exe file will be created:
Code: 
$ g77 layer.for -o layer
layer.for: In subroutine `discrt':
layer.for:37: warning:
         CALL DISCRT (A(N1),A(N2),A(N3),A(N4))                             
              1
layer.for:86: (continued):
         SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)                              
                    2
Argument #4 (named `nboun') of `discrt' is one type at (2) but is some other type at (1) [info -f g77 M GLOBALS]
layer.for: In subroutine `stiff':
layer.for:40: warning:
         CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)                
              1
layer.for:122: (continued):
         SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N)                     
                    2
Argument #4 (named `nboun') of `stiff' is one type at (2) but is some other type at (1) [info -f g77 M GLOBALS]
layer.for: In subroutine `solve':
layer.for:48: warning:
         CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,    
              1
layer.for:166: (continued):
         SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR) 
                    2
Argument #7 (named `maxb') of `solve' is one type at (2) but is some other type at (1) [info -f g77 M GLOBALS]

With g95 it's similar
Code: 
$ g95 layer.for -o layer
In file layer.for:37

      CALL DISCRT (A(N1),A(N2),A(N3),A(N4))                              
                                     1
In file layer.for:86

      SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)                               
                                    2
Warning (155): Inconsistent types (REAL(4)/INTEGER(4)) in actual argument lists at (1) and (2)
In file layer.for:48

      CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,     
                                                      1
In file layer.for:166

      SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR)  
                                           2
Warning (155): Inconsistent types (REAL(4)/INTEGER(4)) in actual argument lists at (1) and (2)
In file layer.for:40

      CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)                 
                                    1
In file layer.for:122

      SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N)                      
                                   2
Warning (155): Inconsistent types (REAL(4)/INTEGER(4)) in actual argument lists at (1) and (2)
It's probably all what I can do for you. I have no idea what the program should do. I hope that you know what input parameters you have to provide.
 
Upvote 0 Downvote
ppippus

... what about a thank you star for mikrom's efforts then ?

The optimist believes we live in the best of all possible worlds - the pessimist fears this might be true.
 
Upvote 0 Downvote
It is right !!!!!! sorry!!!

thanks thanks

I have given one star!!!! using Thank star this post!


thanks
 
Upvote 0 Downvote
I am sorry but I have another problem with this program. I can compile now the code but this a.exe does not work properly. It does not do anything!?
I think that the problem is the input and output file that It does not use if I change the first line of code "(INPUT,OUTPUT,TAPE5=INPUT,... )" I give you these files.

Please can you help me???

LAYER.OUT

1UNDAMPED


NUMBER OF MATERIALS 16
SOLUTION CODE -0
EQ 0 DECONVOLUTION
EQ 1 CONVOLUTION
PRINT CODE -0
EQ 1 WGT.SEQ.PRINTED
EQ 0 NOT PRINTED
PUNCH CODE -0
EQ 1 WGT.SEQ.PUNCHED
EQ 0 NOT PUNCHED
DAMPING COEFF. (ALFA) -0.
DAMPING COEFF. (BETA) -0.





NUMBER OF ACC. CARDS 20
NUMBER OF DEF. POINT 160
NUMBER OF TIME STEPS 160
INPUT CONDITION 3
TIME INCREMENT .01000
FUNCTION MULTIPLIER 32.20000





LAYER MASS SHEAR MOD. MODIFIED MOD. LAYER THICK. SUBLAYER THICK.


1 .00389 300.00000 155.60000 2.00000 2.00000

2 .00389 300.00000 155.60000 2.00000 2.00000

3 .00389 300.00000 155.60000 2.00000 2.00000

4 .00389 300.00000 155.60000 2.00000 2.00000

5 .00389 300.00000 155.60000 2.00000 2.00000

6 .00340 1000.00000 544.00000 4.00000 4.00000

7 .00340 1000.00000 544.00000 4.00000 4.00000

8 .00340 1000.00000 544.00000 4.00000 4.00000

9 .00340 1000.00000 544.00000 4.00000 4.00000

10 .00340 1000.00000 544.00000 4.00000 4.00000

11 .00465 1500.00000 1162.50000 10.00000 5.00000

12 .00465 1500.00000 1162.50000 10.00000 5.00000

13 .00465 1500.00000 1162.50000 10.00000 5.00000

14 .00465 1500.00000 1162.50000 10.00000 5.00000

15 .00465 1500.00000 1162.50000 10.00000 5.00000

16 -0. -0.
1 WEIGHTING SEQUENCE


BAND WIDTH DIAGONAL VALUE
1 .6421502488E+01
1 DATA INTERVAL .02000



INPUT ACCELERATIONS (ROWISE)

-.0626290000 -.0944426000 -.1016232000 -.0383824000 -.0462392000
-.0541282000 -.0591836000 .0307832000 .1616440000 .1559124000
.1996400000 .3056424000 .2992024000 .3153990000 .3299534000
.3185868000 .2700614000 .3142720000 .3942246000 .3841782000
.3359426000 .1454152000 .0387688000 -.1000776000 -.3076710000
-.3847900000 -.4407858000 -.4872826000 -.4645494000 -.3968650000
-.2875138000 -.0800814000 -.0269514000 .0113344000 .2446556000
.2327416000 .1966454000 .1406818000 .0847182000 .0196742000
-.0704214000 -.1023316000 -.1342418000 -.1661198000 -.1980300000
-.2299080000 -.2778860000 -.3709762000 -.4325426000 -.5011286000
-.5271784000 -.5290460000 -.4280346000 -.1552684000 -.0961170000
.0355488000 .1745240000 .1973860000 .2309384000 .2609166000
.3042900000 .2964654000 .2813958000 .2495178000 .2102016000
.1315692000 .0265328000 -.0216062000 -.0772478000 -.1893360000
-.2929556000 -.3406438000 -.3724896000 -.3958668000 -.4122888000
-.3917452000 -.3146906000 -.2894458000 -.2309706000 -.1701770000
-.1445780000 -.1231650000 -.1309574000 -.1387498000 -.1269968000
-.1064854000 -.1042636000 -.0981456000 -.1059380000 -.0826252000
-.0392196000 .0406364000 .1369144000 .1640268000 .1933932000
.2096542000 .2371208000 .2887374000 .3417064000 .3589656000
.3278604000 .2484230000 .1444170000 -.0555772000 -.2793672000
-.4070080000 -.4245892000 -.3320786000 -.2324518000 -.1723022000
-.1191400000 -.0805966000 -.0667506000 .0157780000 .1012046000
.1281238000 .1849568000 .2325484000 .2488416000 .2789808000
.2913456000 .2695140000 .1808352000 .0241178000 -.1087394000
-.2272998000 -.3406760000 -.4150580000 -.4709572000 -.4817442000
-.4502848000 -.4099382000 -.3542000000 -.3362646000 -.3127908000
-.2567306000 -.0497168000 .0716128000 .0958916000 .1445780000
.1600662000 .1358840000 .0378994000 -.0734482000 -.1774220000
-.2138402000 -.1705634000 -.0719026000 .0751226000 .2531564000
.3155600000 .3318532000 .4012764000 .4719554000 .5901938000
.6726258000 .6825434000 .6565258000 .6983536000 .7442708000
1 DECONVOLVED EARTHQUAKE
1 -.00975
2 -.01223
3 -.01471
4 -.01527
5 -.01583
6 -.01090
7 -.00598
8 -.00659
9 -.00720
10 -.00781
11 -.01178
12 -.01302
13 -.01427
14 -.00746
15 -.00064
16 .01124
17 .02312
18 .02246
19 .02181
20 .02500
21 .02309
22 .02991
23 .03673
24 .03834
25 .03995
26 .04729
27 .05463
28 .05529
29 .05595
30 .05591
31 .05253
32 .05053
33 .04853
34 .05527
35 .06202
36 .07571
37 .08939
38 .08856
39 .08772
40 .08523
41 .07299
42 .05857
43 .04415
44 .03861
45 .03307
46 .03349
47 .03390
48 .01729
49 .00069
50 -.00651
51 -.01372
52 -.02271
53 -.03170
54 -.02954
55 -.02738
56 -.01544
57 -.00350
58 -.00425
59 -.00500
60 .00259
61 .01017
62 .02401
63 .03785
64 .03708
65 .03630
66 .03763
67 .03896
68 .05133
69 .06371
70 .06039
71 .05706
72 .04864
73 .04022
74 .03598
75 .03174
76 .03184
77 .03195
78 .02955
79 .02715
80 .01846
81 .00977
82 -.00156
83 -.01288
84 -.02424
85 -.03561
86 -.04823
87 -.06085
88 -.06991
89 -.07897
90 -.08743
91 -.09589
92 -.10076
93 -.10564
94 -.11822
95 -.13080
96 -.13594
97 -.14107
98 -.13841
99 -.13574
100 -.13410
101 -.13246
102 -.12001
103 -.10755
104 -.10084
105 -.09412
106 -.07435
107 -.05457
108 -.03667
109 -.01877
110 -.01386
111 -.00894
112 -.00379
113 .00136
114 -.00316
115 -.00769
116 -.00550
117 -.00331
118 -.00811
119 -.01291
120 -.01494
121 -.01697
122 -.01771
123 -.01845
124 -.01986
125 -.02128
126 -.01587
127 -.01046
128 -.01463
129 -.01879
130 -.02157
131 -.02434
132 -.03084
133 -.03735
134 -.04512
135 -.05288
136 -.05420
137 -.05551
138 -.06783
139 -.08014
140 -.08705
141 -.09396
142 -.09723
143 -.10050
144 -.09640
145 -.09231
146 -.07478
147 -.05725
148 -.05773
149 -.05820
150 -.05117
151 -.04413
152 -.03308
153 -.02203
154 -.02150
155 -.02097
156 -.01755
157 -.01413
158 -.01313
159 -.01212
160 -.01253

-------------------------------------------------
-------------------------------------------------
LAYER.DAT



UNDAMPED
16
20 160 160 3 .01 32.2
1 .00389 300. 2.
2 .00389 300. 2.
3 .00389 300. 2.
4 .00389 300. 2.
5 .00389 300. 2.
6 .00340 1000. 4.
7 .00340 1000. 4.
8 .00340 1000. 4.
9 .00340 1000. 4.
10 .00340 1000. 4.
11 .00465 1500. 10.
12 .00465 1500. 10.
13 .00465 1500. 10.
14 .00465 1500. 10.
15 .00465 1500. 10.
16
.02
-.001945 -.002933 -.003156 -.001192 -.001436 -.001681 -.001838 .000956 1
.005020 .004842 .006200 .009492 .009292 .009795 .010247 .009894 2
.008387 .009760 .012243 .011931 .010433 .004516 .001204 -.003108 3
-.009555 -.011950 -.013689 -.015133 -.014427 -.012325 -.008929 -.002487 4
-.000837 .000352 .007598 .007228 .006107 .004369 .002631 .000611 5
-.002187 -.003178 -.004169 -.005159 -.006150 -.007140 -.008630 -.011521 6
-.013433 -.015563 -.016372 -.016430 -.013293 -.004822 -.002985 .001104 7
.005420 .006130 .007172 .008103 .009450 .009207 .008739 .007749 8
.006528 .004086 .000824 -.000671 -.002399 -.005880 -.009098 -.010579 9
-.011568 -.012294 -.012804 -.012166 -.009773 -.008989 -.007173 -.005285 10
-.004490 -.003825 -.004067 -.004309 -.003944 -.003307 -.003238 -.003048 11
-.003290 -.002566 -.001218 .001262 .004252 .005094 .006006 .006511 12
.007364 .008967 .010612 .011148 .010182 .007715 .004485 -.001726 13
-.008676 -.012640 -.013186 -.010313 -.007219 -.005351 -.003700 -.002503 14
-.002073 .000490 .003143 .003979 .005744 .007222 .007728 .008664 15
.009048 .008370 .005616 .000749 -.003377 -.007059 -.010580 -.012890 16
-.014626 -.014961 -.013984 -.012731 -.011000 -.010443 -.009714 -.007973 17
-.001544 .002224 .002978 .004490 .004971 .004220 .001177 -.002281 18
-.005510 -.006641 -.005297 -.002233 .002333 .007862 .009800 .010306 19
.012462 .014657 .018329 .020889 .021197 .020389 .021688 .023114 20

 
Upvote 0 Downvote
Your problem seems to be that your program expects input from your keyboard ( Read (5, ...) --> 5 today indicating keyboard). But in the very old days, when we had punched cards, 5 was the reader for punched cards. So you should reorganize your input files.

First establish the name of your inputfile and save it to the same directory as your program's executable. Lets name this file 'input.dat'

Then open this file for input before the first read statement

Code: 
open (unit = 10, file = 'input.dat', status = 'OLD') 
C  change the units in all your read statements to 10
C  50  READ(5,1001) 
   50  READ(10,1001) HED,NUMAT,IC,MPR,MP,ALFA,BETA                           A   5
      IF(NUMAT.EQ.0)  STOP                                                 A   6
.....
.....

Same with your write statements. Back in the days of old, unit 6 was the lineprinter. you may keep it that way, but if you want to have your output in a file then you need before the first write statement

Code: 
open (unit = 12, file = 'output.dat', status = 'REPLACE') 
C change the units in all your write statements to 12
C      WRITE(6,2002) NUCAR,NPOINT,MMAX,NC,DT,FACT                           A  11
      WRITE(12,2002) NUCAR,NPOINT,MMAX,NC,DT,FACT                           A  11
...
...

You may select your names and unit numbers to your liking, of course. (It is just my programming style to use numbers > 10 not to mess with any standard io-units).

Norbert


The optimist believes we live in the best of all possible worlds - the pessimist fears this might be true.
 
Upvote 0 Downvote
I am sorry but the program does not compile after the last changes.I have with g77 some errors:

Microsoft Windows XP [Versione 5.1.2600]
(C) Copyright 1985-2001 Microsoft Corp.

C:\Documents and Settings\Basili>cd
C:\>g77 LAYERDL3.FOR
LAYERDL3.FOR: In subroutine `discrt':
LAYERDL3.FOR:39: warning:
CALL DISCRT (A(N1),A(N2),A(N3),A(N4))
1
LAYERDL3.FOR:88: (continued):
SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)
2
Argument #4 (named `nboun') of `discrt' is one type at (2) but is some other typ
e at (1) [info -f g77 M GLOBALS]
LAYERDL3.FOR: In subroutine `stiff':
LAYERDL3.FOR:42: warning:
CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)
1
LAYERDL3.FOR:123: (continued):
SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N)
2
Argument #4 (named `nboun') of `stiff' is one type at (2) but is some other type
at (1) [info -f g77 M GLOBALS]
LAYERDL3.FOR: In subroutine `solve':
LAYERDL3.FOR:245:
IF(MP.EQ.1) WRITE 2001, (G(K), K=1,NTOT)
^
Invalid form for WRITE statement at (^)
LAYERDL3.FOR:50: warning:
CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,
1
LAYERDL3.FOR:167: (continued):
SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR)
2
Argument #7 (named `maxb') of `solve' is one type at (2) but is some other type
at (1) [info -f g77 M GLOBALS]
LAYERDL3.FOR: In subroutine `conv':
LAYERDL3.FOR:451:
WRITE 2001, STO
^
Invalid form for WRITE statement at (^)

C:\>




the modified code is:


PROGRAM LAYER A 1
. A 2
COMMON NUMAT,DT,N,ALFA,BETA,HED(12),A(30000) A 3
C LAYER.A
C ***** NOTICE TO USERS OF THIS SOFTWARE ***** LAYER.B
C LAYER.C
C COPYRIGHT (C) 1971 LAYER.D
C THE REGENTS OF THE UNIVERSITY OF CALIFORNIA (REGENTS) LAYER.E
C ALL RIGHTS RESERVED LAYER.F
C LAYER.G
C IN NO EVENT SHALL REGENTS OF THE UNIVERSITY OF CALIFORNIA BE LAYER.H
C LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, LAYER.I
C OR CONSEQUENTIAL DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF LAYER.J
C THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IT REGENTS LAYER.K
C HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. LAYER.L
C LAYER.M
C REGENTS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT LAYER.N
C NOT LIMITED TO, THE IMPLIED WARRANTIES OR MERCHANTABILITY AND LAYER.O
C FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE AND ACCOMPANYING LAYER.P
C DOCUMENTATION, IF ANY, PROVIDED HEREUNDER IS PROVIDED "AS IS". LAYER.Q
C REGENTS HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, LAYER.R
C UPDATES, ENHANCEMENTS, OR MODIFICATIONS. LAYER.S
C LAYER.T
C A 4
open (unit = 10, file = 'input.dat', status = 'OLD')
open (unit = 12, file = 'output.dat', status = 'REPLACE')
50 READ(10,1001) HED,NUMAT,IC,MPR,MP,ALFA,BETA A 5
IF(NUMAT.EQ.0) STOP A 6
WRITE(12,2001)HED,NUMAT,IC,MPR,MP,ALFA,BETA A 7
NUMAT=NUMAT-1 A 8
READ(10,1002) NUCAR,NPOINT,MMAX,NC,DT,FACT A 9
IF (FACT.EQ.0.0) FACT=1.0 A 10
WRITE(12,2002) NUCAR,NPOINT,MMAX,NC,DT,FACT A 11
N1=1 A 12
N2=N1+NUMAT A 13
N3=N2+NUMAT A 14
N4=N3+NUMAT A 15
C A 16
CALL DISCRT (A(N1),A(N2),A(N3),A(N4)) A 17
N5=N4+NUMAT A 18
N6=N5+N A 19
CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N) A 20
N2=N1+N A 21
N3=N2+2*N A 22
N4=N3+N A 23
N5=N4+N A 24
N6=N5+N A 25
N7=N6+N A 26
N8=N7+N A 27
CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N, A 28
. MMAX,NMAX,MP,MPR) A 29
NM=MMAX+NMAX-1 A 30
N2=N1+NM A 31
N3=N2+MMAX A 32
N4=N3+NPOINT A 33
CALL LOAD (A(N2),A(N3),A(N4),NUCAR,MMAX,NC,DT,FACT) A 34
IF(IC.EQ.0) GO TO 70 A 35
CALL CONV(A(N1),A(N2),MMAX,MP) A 36
GO TO 50 A 37
70 IF(ALFA.EQ.0.0.AND.BETA.EQ.0.0) GO TO 80 A 38
CALL GESOL (A(N1),A(N2),A(N3),NMAX,MMAX) A 39
GO TO 50 A 40
80 CALL REV (A(N1),A(N2),A(N3),NM) A 41
GO TO 50 A 42
C A 43
1001 FORMAT (12A6/4I5,2F10.0) A 44
1002 FORMAT (4I5,2F10.0) A 45
2001 FORMAT (1H1,12A6/// A 46
. 20H NUMBER OF MATERIALS ,I5/ A 47
. 20H SOLUTION CODE ,I5/ A 48
. 20H EQ 0 DECONVOLUTION / A 49
. 20H EQ 1 CONVOLUTION / A 50
. 20H PRINT CODE ,I5/ A 51
. 21H EQ 1 WGT.SEQ.PRINTED / A 52
. 21H EQ 0 NOT PRINTED / A 53
C . 20H PUNCH CODE ,I5/ A 54
C . 21H EQ 1 WGT.SEQ.PUNCHED / A 55
C . 21H EQ 0 NOT PUNCHED / A 56
3 22H DAMPING COEFF. (ALFA) ,F10.6/ A 57
4 22H DAMPING COEFF. (BETA) ,F10.6/////) A 58
2002 FORMAT (21H NUMBER OF ACC. CARDS ,I5/ A 59
. 21H NUMBER OF DEF. POINT ,I5/ A 60
. 21H NUMBER OF TIME STEPS ,I5/ A 61
. 20H INPUT CONDITION ,I5/ A 62
. 20H TIME INCREMENT ,F10.5/ A 63
. 20H FUNCTION MULTIPLIER ,F10.5/////) A 64
END A 65
SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN) B 1
COMMON NUMAT,DT,N,ALFA,BETA,DHS B 2
DIMENSION SMU(1),SMOD(1),H(1),NBOUN(1) B 3
C B 4
WRITE(12,3000) B 5
NJ=1 B 6
DO 50 I=1,NUMAT B 7
READ (5,1001) MAT,SMU(MAT),SMOD(MAT),H(MAT) B 8
C=SQRT(SMOD(I)/SMU(I)) B 9
CC=C*DT B 10
SN=H(I)/CC B 11
IF (SN.LE.0.5) SN=1.0 B 12
NS=SN B 13
IF ((SN-NS).GE.0.5) NS=NS+1 B 14
NJ=NJ+NS B 15
NBOUN(I)=NJ B 16
SM=SMOD(I) B 17
SMOD(I)=(H(I)*H(I)*SMU(I))/(NS*NS*DT*DT) B 18
DX=SQRT(SMOD(I)/SMU(I))*DT B 19
WRITE(12,2001)MAT,SMU(MAT),SM,SMOD(MAT),H(MAT),DX B 20
H(I)=DX B 21
50 CONTINUE B 22
N=NBOUN(NUMAT) B 23
READ(10,1001) MAT,SMUH,SMODH B 24
DHS=1.0E+38 B 25
IF(SMUH.EQ.0.0) GO TO 60 B 26
DHS=SMUH*SQRT(SMODH/SMUH) B 27
60 WRITE(12,2001) MAT,SMUH,SMODH B 28
C B 29
RETURN B 30
1001 FORMAT(I5,3F10.0) B 31
2001 FORMAT(I8,5F20.5/) B 32
3000 FORMAT(1H ,5X,5HLAYER,12X,4HMASS,11X,10HSHEAR MOD.,9X,13HMODIFIED B 33
.MOD.,9X,12HLAYER THICK.,6X,15HSUBLAYER THICK.,//) B 34
END B 35
SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N) C 1
DIMENSION SMU(1),SMOD(1),H(1),NBOUN(1),SMASS(N),A(N,2) C 2
C*********************************************************************** C 3
C FORM STIFFNESS AND MASS MATRICES C 4
C*********************************************************************** C 5
N1=N-1 C 6
L=1 C 7
K=2 C 8
NB=NBOUN(1) C 9
SK2=-SMOD(1)/H(1) C 10
SK1=-2.0*SK2 C 11
SM=SMU(1)*H(1) C 12
A(1,1)=SK1/2.0 C 13
A(1,2)=SK2 C 14
SMASS(1)=SM/2.0 C 15
IF(N.EQ.2) GO TO 40 C 16
DO 50 I=2,N1 C 17
IF(I.EQ.NB) GO TO 60 C 18
A(I,1)=SK1 C 19
A(I,2)=SK2 C 20
SMASS(I)=SM C 21
GO TO 50 C 22
60 SK1=SMOD(L)/H(L) C 23
SK2=SMOD(K)/H(K) C 24
SM2=SMU(K)*H(K) C 25
A(I,1)=SK1+SK2 C 26
A(I,2)=-SK2 C 27
SMASS(I)=(SM+SM2)/2.0 C 28
SK1=2.0*SK2 C 29
SK2=-SK2 C 30
SM=SM2 C 31
L=L+1 C 32
K=K+1 C 33
NB=NBOUN(L) C 34
50 CONTINUE C 35
40 A(N,1)=-SK2 C 36
SMASS(N)=SM/2.0 C 37
A(N,2)=0.0 C 38
C C 39
REWIND 2 C 40
WRITE (2) SMASS,A C 41
C C 42
RETURN C 43
END C 44
SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR) D 1
COMMON NUMAT,DT,N1,ALFA,BETA,DHS D 2
DIMENSION SMASS(N),A(N,2),X0(1),X1(1),X2(1),B(1),MAXB(1),G(1) D 3
C D 4
REWIND 2 D 5
READ (2) SMASS,A D 6
C D 7
C*********************************************************************** D 8
C INITIAL CONDITIONS D 9
C*********************************************************************** D 10
WRITE (6,3000) D 11
NT=0 D 12
NTOT=NUACC+N D 13
DO 100 I=1,N D 14
X0(I)=0. D 15
X1(I)=0. D 16
100 X2(I)=0. D 17
IF(BETA.NE.0.0) GO TO 75 D 18
A1=DT*DT/2. D 19
A2=2./(ALFA*DT*DT+2.*DT) D 20
A3=DT/(ALFA*DT+2.) D 21
A4=2./DT D 22
A5=1./A3 D 23
E1=SMASS(N)/(SMASS(N)*A5+DHS) D 24
E2=E1/A1 D 25
NLS=N-1 D 26
DO 177 I=1,NLS D 27
177 SMASS(I)=A5*SMASS(I) D 28
SMASS(N)=A5*SMASS(N)+DHS D 29
GO TO 175 D 30
75 A0=ALFA+2./DT D 31
A1=DT*DT/2. D 32
A2=2./(DT*DT)+ALFA/BETA+2./(BETA*DT) D 33
A3=2./(DT*DT) D 34
A4=1./BETA D 35
A5=2./DT D 36
A6=DHS/BETA D 37
DO 150 I=1,N D 38
A(I,1)=A0*SMASS(I)+BETA*A(I,1) D 39
150 A(I,2)=BETA*A(I,2) D 40
A(N,1)=A(N,1)+DHS D 41
GO TO 200 D 42
C*********************************************************************** D 43
C NUMERICAL INTEGRATION AND STORE WEIGHTING SEQUENCE D 44
C*********************************************************************** D 45
175 BAC=0. D 46
IF(NT.EQ.0) BAC=2. D 47
DO 180 I=1,N D 48
TEMP=DT*X1(I)+A1*X2(I) D 49
VEL=A2*TEMP D 50
X2(I)=A4*X1(I)+X2(I) D 51
X1(I)=VEL-A3*BAC D 52
180 X0(I)=X0(I)+TEMP D 53
X1(N)=E2*TEMP-E1*BAC D 54
CALL MULT (A,X0,B,N,2) D 55
DO 190 I=1,N D 56
X1(I)=X1(I)-B(I)/SMASS(I) D 57
190 X2(I)=A4*X1(I)-X2(I) D 58
GO TO 325 D 59
200 CALL TRIA(N,2,A,MAXB) D 60
275 IF(BETA.EQ.0.0) GO TO 175 D 61
BAC=0. D 62
IF(NT.EQ.0) BAC=2. D 63
DO 250 I=1,N D 64
DIS=X0(I)+DT*X1(I)+A1*X2(I) D 65
B(I)=-BAC*SMASS(I)+SMASS(I)*(A2*DIS-A3*X0(I)) D 66
250 X0(I)=DIS D 67
B(N)=B(N)+A6*X0(N) D 68
CALL BACKS(N,2,A,MAXB,B) D 69
DO 300 I=1,N D 70
VEL=B(I)-A4*X0(I) D 71
X2(I)=A5*(VEL-X1(I))-X2(I) D 72
300 X1(I)=VEL D 73
325 NT=NT+1 D 74
G(NT)=X2(1)+BAC D 75
IF(MPR) 330,335,330 D 76
330 WRITE (6,2000) NT,G(NT) D 77
335 IF(NT.LT.NTOT) GO TO 275 D 78
IF(MP.EQ.1) WRITE 2001, (G(K), K=1,NTOT) D 79
GMAX=G(N)/500. D 80
DO 400 I=1,NTOT D 81
400 IF(ABS(G(I)).LT.GMAX) G(I)=0. D 82
DO 410 I=1,NTOT D 83
IF(G(I).EQ.0.0) GO TO 410 D 84
KX=I-1 D 85
GO TO 420 D 86
410 CONTINUE D 87
420 NTG=NTOT-KX D 88
DO 425 I=1,NTG D 89
425 SMASS(I)=G(I+KX) D 90
NMAX=N-KX D 91
WRITE(12,3001) D 92
WRITE (6,2000) NMAX,SMASS(NMAX) D 93
C D 94
RETURN D 95
2000 FORMAT (I10,E20.10) D 96
2001 FORMAT(4E20.14) D 97
3000 FORMAT(1H1,5X,18HWEIGHTING SEQUENCE) D 98
3001 FORMAT(//,3X,10HBAND WIDTH,4X,14HDIAGONAL VALUE) D 99
END D 100
SUBROUTINE TRIA(NEQ,MBAND,A,NBMAX) E 1
DIMENSION A(1),NBMAX(1) E 2
C E 3
C TRIANGULARIZE BANDED MATRIX BY GAUSS ELIMINATION E 4
C E 5
IF(NEQ.EQ.1)RETURN E 6
MM=NEQ*MBAND E 7
NE=NEQ-1 E 8
DO 300 N=1,NE E 9
C E 10
C DETERMINE EQUATION LENGTH E 11
C E 12
NBMAX(N)=0 E 13
DO 100 I=N,MM,NEQ E 14
IF(A(I).NE.0.0) NBMAX(N)=I E 15
100 CONTINUE E 16
IF (A(N).EQ.0.0) GO TO 300 E 17
C E 18
C SUBSTITUTE INTO EQUATIONS WITHIN BAND E 19
C E 20
IL=N+NEQ E 21
IH=NBMAX(N) E 22
L=N E 23
DO 200 I=IL,IH,NEQ E 24
L=L+1 E 25
IF(A(I).EQ.0.0) GO TO 200 E 26
C=A(I)/A(N) E 27
J=L-I E 28
DO 50 K=I,IH,NEQ E 29
50 A(K+J)=A(K+J)-C*A(K) E 30
A(I)=C E 31
200 CONTINUE E 32
300 CONTINUE E 33
C E 34
RETURN E 35
END E 36
SUBROUTINE BACKS(NEQ,MBAND,A,NBMAX,B) F 1
DIMENSION A(1),B(1),NBMAX(1) F 2
IL=NEQ F 3
C F 4
DO 400 N=1,NEQ F 5
C=B(N) F 6
IF(A(N).NE.0.0) B(N)=B(N)/A(N) F 7
IF(N.EQ.NEQ) GO TO 450 F 8
IL=IL+1 F 9
IH=NBMAX(N) F 10
K=N F 11
DO 350 I=IL,IH,NEQ F 12
K=K+1 F 13
350 B(K)=B(K)-A(I)*C F 14
400 CONTINUE F 15
C F 16
450 IL=2*NEQ F 17
500 IL=IL-1 F 18
N=N-1 F 19
IF(N.EQ.0) RETURN F 20
IH=NBMAX(N) F 21
K=N F 22
DO 600 I=IL,IH,NEQ F 23
K=K+1 F 24
600 B(N)=B(N)-A(I)*B(K) F 25
C F 26
GO TO 500 F 27
C F 28
END F 29
SUBROUTINE MULT (A,B,C,NEQ,MB) G 1
DIMENSION A(NEQ,1),B(1),C(1) G 2
C G 3
NN=NEQ-MB+1 G 4
MX=MB G 5
C G 6
DO 200 N=1,NEQ G 7
C(N)=0.0 G 8
IF(N.GT.NN) MX=MX-1 G 9
N1=N-1 G 10
DO 100 J=1,MX G 11
100 C(N)=C(N)+A(N,J)*B(J+N1) G 12
200 CONTINUE G 13
IF(NEQ.EQ.1) RETURN G 14
C G 15
DO 400 N=2,NEQ G 16
IF(N.LE.MB) MX=N G 17
N1=N+1 G 18
DO 300 J=2,MX G 19
300 C(N)=C(N)+A(N1-J,J)*B(N1-J) G 20
400 CONTINUE G 21
C G 22
RETURN G 23
END G 24
SUBROUTINE LOAD (A,T,AC,NUCAR,MMAX,NC,DX,FACT) H 1
DIMENSION A(MMAX),T(1),AC(1) H 2
IF(NC.NE.1) GO TO 10 H 3
WRITE(12,3001) H 4
DO 100 I=1,NUCAR H 5
READ(10,1001) T(I),AC(I) H 6
AC(I)=FACT*AC(I) H 7
WRITE(12,2001) T(I),AC(I) H 8
100 CONTINUE H 9
GO TO 40 H 10
10 IF(NC.NE.2) GO TO 20 H 11
WRITE(12,3002) H 12
K=1 H 13
DO 200 I=1,NUCAR H 14
KK = 5*I H 15
READ(10,1002) (T(J),AC(J),J=K,KK) H 16
WRITE(12,2002) (T(J),AC(J),J=K,KK) H 17
200 K=KK+1 H 18
NUCAR=6*NUCAR H 19
DO 250 I=1,NUCAR H 20
250 AC(I)=FACT*AC(I) H 21
GO TO 40 H 22
20 IF(NC.NE.3) GO TO 50 H 23
READ(10,1003) DT H 24
WRITE(12,2003) DT H 25
WRITE(12,3004) H 26
NUCAR=8*NUCAR H 27
T(1)=0.0 H 28
DO 300 I=2,NUCAR H 29
300 T(I)=T(I-1)+DT H 30
READ (5,1004) (AC(I),I=1,NUCAR) H 31
DO 350 I=1,NUCAR H 32
350 AC(I)=FACT*AC(I) H 33
WRITE (6,2004) (AC(I),I=1,NUCAR) H 34
40 CALL INTPOL (T,AC,MMAX,DX,A) H 35
GO TO 500 H 36
50 READ(10,1004) (A(I),I=1,MMAX) H 37
WRITE(12,3005) H 38
DO 400 I=1,MMAX H 39
400 A(I)=FACT*A(I) H 40
WRITE(12,2004) (A(I),I=1,MMAX) H 41
C H 42
500 CONTINUE H 43
C H 44
RETURN H 45
1001 FORMAT(2F10.0) H 46
1002 FORMAT(5(F7.3,F7.3)) H 47
1003 FORMAT(F10.0) H 48
1004 FORMAT (8F9.0) H 49
2001 FORMAT (F8.4,10X,F12.8) H 50
2002 FORMAT(5(F7.3,F7.3)) H 51
2003 FORMAT (20H1 DATA INTERVAL ,F10.5///) H 52
2004 FORMAT (5F20.10) H 53
3001 FORMAT(40H1 TIME INPUT ACCELERATIONS ///) H 54
3002 FORMAT(1H1,32HTIMES AND ACCELERATIONS AS INPUT,/, H 55
1 58HTIME ACCL TIME ACCL TIME ACCL TIME ACCL TIME ACCL) H 56
3004 FORMAT ( 40H INPUT ACCELERATIONS (ROWISE) /) H 57
3005 FORMAT (1H1,40H INPUT ACCELERATIONS (ROWISE) /) H 58
END H 59
SUBROUTINE INTPOL (X, Y, MMAX, DX, A) I 1
C I 2
C SUBROUTINE TO INTERPOLATE A FUNCTION AT EQUAL INTERVALS OF X COORD I 3
C I 4
DIMENSION X(1),Y(1),A(1) I 5
N = 2 I 6
A(1) = Y(1) I 7
X1 = X(1) I 8
DO 300 M = 2, MMAX I 9
EM = M I 10
GO TO 304 I 11
301 N = N + 1 I 12
304 B = (EM-1.0)*DX - X(N-1) + X1 I 13
C = X(N) - X(N-1) I 14
IF (C-B) 301,302,303 I 15
302 A(M) = Y(N) I 16
GO TO 300 I 17
303 SLOPE = (Y(N) - Y(N-1)) / C I 18
A(M) = Y(N-1) + B*SLOPE I 19
C I 20
300 CONTINUE I 21
RETURN I 22
END I 23
SUBROUTINE CONV (G,F,NT, MP) J 1
DIMENSION G(1),F(1), STO(4) J 2
WRITE (6,3000) J 3
KS = 0 J 4
DO 200 K=1,NT J 5
H=0.0 J 6
K1=K+1 J 7
KS = KS + 1 J 8
DO 100 I=1,K J 9
100 H=H+F(I)*G(K1-I) J 10
IF(MP.EQ.0) GO TO 200 J 11
STO(KS) = H J 12
IF(KS.NE.4) GO TO 200 J 13
WRITE 2001, STO J 14
KS = 0 J 15
200 WRITE(12,2000) K,H J 16
C J 17
RETURN J 18
2000 FORMAT(I10,F10.5) J 19
2001 FORMAT(4E20.14) J 20
3000 FORMAT (30H1 CONVOLVED EARTHQUAKE ) J 21
END J 22
SUBROUTINE GESOL (TF,B,A,MBAND,NN) K 1
DIMENSION TF(1),B(1),A(MBAND,1) K 2
C K 3
REWIND 1 K 4
MB1=MBAND-1 K 5
NN1=NN+1 K 6
NN2=NN/2 K 7
DO 50 I=1,NN2 K 8
TEMP=B(I) K 9
II=NN1-I K 10
B(I)=B(II) K 11
50 B(II)=TEMP K 12
C K 13
DO 100 I=1,MBAND K 14
MB=MBAND-I K 15
DO 100 J=1,NN K 16
K=MB+J K 17
100 A(I,J)=TF(K) K 18
C K 19
DO 475 N=1,NN K 20
N2=N-1 K 21
N1=N+1 K 22
B(N)=B(N)/A(1,N) K 23
IF(N.EQ.NN) GO TO 490 K 24
DO 250 J=N1,NN K 25
IF(A(1,J).EQ.0.0) GO TO 250 K 26
A(1,J)=A(1,J)/A(1,N) K 27
C=A(1,J) K 28
DO 260 I=2,MBAND K 29
260 A(I,J)=A(I,J)-A(I,N)*C K 30
250 CONTINUE K 31
C K 32
DO 300 I=2,MBAND K 33
II=I+N2 K 34
300 B(II)=B(II)-A(I,N)*B(N) K 35
WRITE (1) (A(1,J),J=N1,NN) K 36
DO 400 I=1,MB1 K 37
I1=I+1 K 38
DO 400 J=N1,NN K 39
400 A(I,J)=A(I1,J) K 40
C K 41
K=0 K 42
DO 450 J=N1,NN K 43
K=K+1 K 44
450 A(MBAND,J)=TF(K) K 45
475 CONTINUE K 46
C K 47
490 BACKSPACE 1 K 48
500 N1=N K 49
N=N-1 K 50
IF(N.EQ.0) GO TO 700 K 51
READ (1) (A(1,J),J=N1,NN) K 52
BACKSPACE 1 K 53
BACKSPACE 1 K 54
DO 600 J=N1,NN K 55
600 B(N)=B(N)-A(1,J)*B(J) K 56
GO TO 500 K 57
700 DO 800 I=1,NN2 K 58
TEMP=B(I) K 59
II=NN1-I K 60
B(I)=B(II) K 61
800 B(II)=TEMP K 62
WRITE (6,3000) K 63
WRITE (6,2000) (I,B(I),I=1,NN) K 64
C K 65
RETURN K 66
2000 FORMAT (I10,F20.5) K 67
3000 FORMAT(1H1,4X,22HDECONVOLVED EARTHQUAKE) K 68
END K 69
SUBROUTINE REV (G,US,UB,NT) L 1
DIMENSION US(1),G(1),UB(NT) L 2
NT1=NT-1 L 3
DO 100 N=1,NT1 L 4
UB(N)=US(N)/G(1) L 5
IF (N.EQ.NT) GO TO 100 L 6
N1=N+1 L 7
DO 200 I=N1,NT L 8
II=I-N+1 L 9
200 US(I)=US(I)-UB(N)*G(II) L 10
100 CONTINUE L 11
UB(NT)=US(NT)/G(1) L 12
WRITE (6,3000) L 13
WRITE (6,2000) (I,UB(I),I=1,NT) L 14
C L 15
RETURN L 16
2000 FORMAT (I10,F20.5) L 17
3000 FORMAT(1H1,4X,22HDECONVOLVED EARTHQUAKE) L 18
END L 19


can you help me please?

thanks

 
Upvote 0 Downvote
As g77 said
Code: 
WRITE 2001, STO
is wrong. In your case it should be probably
Code: 
WRITE (12, 2001) STO

 
Upvote 0 Downvote
(1)
C:\>g77 LAYERDL3.FOR
LAYERDL3.FOR: In subroutine `discrt':
LAYERDL3.FOR:39: warning:
CALL DISCRT (A(N1),A(N2),A(N3),A(N4))
1
LAYERDL3.FOR:88: (continued):
SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)
2
Argument #4 (named `nboun') of `discrt' is one type at (2) but is some other typ

Throughout your code implicit variable types are used. All variables starting i to n as first letters are integers, all the other are reals. So in the call to DISCRT the fourth argument is a real, in the program itself an integer. I do not know if a(4) gives a sensible value as integer for your program, but I would change this line to

Code: 
C       CALL DISCRT (A(N1),A(N2),A(N3),A(N4))
        CALL DISCRT (A(N1),A(N2),A(N3),int(A(N4)))

Same in the call to STIFF, change that to

Code: 
C        CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)
         CALL STIFF (A(N1),A(N2),A(N3),int(A(N4)),A(N5),A(N6),N)

and last but not least the same happens in the call to SOLVE but the parameter in question is a(n7)this time. So change this call to

Code: 
C         CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,
          CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),int(A(N7)),A(N8),N,

As to the write statements WRITE 2001, STO you should folow mikroms advice.

Let's see what happens then ...

And, you may safely delete the counters at the end of the lines (a 1, a 2 etc.). These counters were used with punched cards so you can easily rearrange when needed. (must be a very old prog !)

Norbert




The optimist believes we live in the best of all possible worlds - the pessimist fears this might be true.
 
Upvote 0 Downvote
ppippus,
What you posted as input data doens't work, I guess it's only the output from the program.
I doesn't have problem to compile the program, but the biggest problem for me is to create a data file which will be accepted from the program.

 
Upvote 0 Downvote
I have a problem with reading the accelerations in SUBROUTINE LOAD.

The accelerations data posted by ppippus are:
Code: 
-.0626290000 -.0944426000 -.1016232000 ....
...
I don't understand how the data need to be formatted in a file, when they should be read with this formatted read
Code: 
READ (5,1004) (AC(I),I=1,NUCAR)
...
1004 FORMAT (8F9.0)
I have made several attempts, with 8 rows of 9 digits numbers and other things, but none or them works.
I would be very thankful, if someone could explain how the above numbers should be formatted in a text file, so we would be able to read them with the above formatted read statement.
 
Upvote 0 Downvote
I replaced the formatted read in SUBROUTINE LOAD with unformatted
read:
Code: 
C     READ (5,1004) (AC(I),I=1,NUCAR)
      read (5,*) (AC(I),I=1,NUCAR)
Now the program works (however I don't know how reasonable are the data...)
It accepts an input file like this:
tape5.dat
Code: 
AAAAAABBBBBBCCCCCCDDDDDDEEEEEEFFFFFFGGGGGGHHHHHHIIIIIIJJJJJJKKKKKKLLLLLL
00016 0000 0000 0000 00000.00 000000.00
00020 0160 0160 0003 00000.01 000032.20
1     0.00389    300.00000   155.60000   2.00000   2.00000
2     0.00389    300.00000   155.60000   2.00000   2.00000
3     0.00389    300.00000   155.60000   2.00000   2.00000
4     0.00389    300.00000   155.60000   2.00000   2.00000
5     0.00389    300.00000   155.60000   2.00000   2.00000
6     0.00340   1000.00000   544.00000   4.00000   4.00000
7     0.00340   1000.00000   544.00000   4.00000   4.00000
8     0.00340   1000.00000   544.00000   4.00000   4.00000
9     0.00340   1000.00000   544.00000   4.00000   4.00000
10    0.00340   1000.00000   544.00000   4.00000   4.00000
11    0.00465   1500.00000  1162.50000  10.00000   5.00000
12    0.00465   1500.00000  1162.50000  10.00000   5.00000
13    0.00465   1500.00000  1162.50000  10.00000   5.00000
14    0.00465   1500.00000  1162.50000  10.00000   5.00000
15    0.00465   1500.00000  1162.50000  10.00000   5.00000
16   -0.          -0.
0.02
-.0626290000 -.0944426000 -.1016232000 -.0383824000 -.0462392000 -.0541282000 -.0591836000  .0307832000 
 .1616440000  .1559124000  .1996400000  .3056424000  .2992024000  .3153990000  .3299534000  .3185868000 
 .2700614000  .3142720000  .3942246000  .3841782000  .3359426000  .1454152000  .0387688000 -.1000776000 
-.3076710000 -.3847900000 -.4407858000 -.4872826000 -.4645494000 -.3968650000 -.2875138000 -.0800814000 
-.0269514000  .0113344000  .2446556000  .2327416000  .1966454000  .1406818000  .0847182000  .0196742000 
-.0704214000 -.1023316000 -.1342418000 -.1661198000 -.1980300000 -.2299080000 -.2778860000 -.3709762000 
-.4325426000 -.5011286000 -.5271784000 -.5290460000 -.4280346000 -.1552684000 -.0961170000  .0355488000 
 .1745240000  .1973860000  .2309384000  .2609166000  .3042900000  .2964654000  .2813958000  .2495178000 
 .2102016000  .1315692000  .0265328000 -.0216062000 -.0772478000 -.1893360000 -.2929556000 -.3406438000 
-.3724896000 -.3958668000 -.4122888000 -.3917452000 -.3146906000 -.2894458000 -.2309706000 -.1701770000 
-.0626290000 -.0944426000 -.1016232000 -.0383824000 -.0462392000 -.0541282000 -.0591836000  .0307832000 
 .1616440000  .1559124000  .1996400000  .3056424000  .2992024000  .3153990000  .3299534000  .3185868000 
 .2700614000  .3142720000  .3942246000  .3841782000  .3359426000  .1454152000  .0387688000 -.1000776000 
-.3076710000 -.3847900000 -.4407858000 -.4872826000 -.4645494000 -.3968650000 -.2875138000 -.0800814000 
-.0269514000  .0113344000  .2446556000  .2327416000  .1966454000  .1406818000  .0847182000  .0196742000 
-.0704214000 -.1023316000 -.1342418000 -.1661198000 -.1980300000 -.2299080000 -.2778860000 -.3709762000 
-.4325426000 -.5011286000 -.5271784000 -.5290460000 -.4280346000 -.1552684000 -.0961170000  .0355488000 
 .1745240000  .1973860000  .2309384000  .2609166000  .3042900000  .2964654000  .2813958000  .2495178000 
 .2102016000  .1315692000  .0265328000 -.0216062000 -.0772478000 -.1893360000 -.2929556000 -.3406438000 
-.3724896000 -.3958668000 -.4122888000 -.3917452000 -.3146906000 -.2894458000 -.2309706000 -.1701770000 
STOP
00000 0000 0000 0000 00000.00 000000.00
in subroutine STIFF it produces temporary file which will be then used in subroutine SOLVE
tape2.dat
Code: 
  5.40432194E-03  1.08086439E-02  1.08086439E-02  1.08086439E-02  1.08086439E-02 ...
...
and prints output like this:
Code: 
1  AAAA  BBBB  CCCC  DDDD  EEEE  FFFF  GGGG  HHHH  IIII  JJJJ  KKKK  LLLL


 NUMBER OF MATERIALS   16
 SOLUTION CODE          0
 EQ 0 DECONVOLUTION 
 EQ 1 CONVOLUTION   
 PRINT CODE             0
 EQ 1 WGT.SEQ.PRINTED
 EQ 0 NOT PRINTED    
 PUNCH CODE             0
 EQ 1 WGT.SEQ.PUNCHED
 EQ 0 NOT PUNCHED    
 DAMPING COEFF. (ALFA)  0.000000
 DAMPING COEFF. (BETA)  0.000000





 NUMBER OF ACC. CARDS   20
 NUMBER OF DEF. POINT  160
 NUMBER OF TIME STEPS  160
 INPUT CONDITION        3
 TIME INCREMENT        0.01000
 FUNCTION MULTIPLIER  32.20000





 * executing subroutine DISCRT
      LAYER            MASS           SHEAR MOD.         MODIFIED MOD.         LAYER THICK.      SUBLAYER THICK.


       1             0.00389           300.00000           300.32590           155.60001             2.77857

       2             0.00389           300.00000           300.32590           155.60001             2.77857

       3             0.00389           300.00000           300.32590           155.60001             2.77857

       4             0.00389           300.00000           300.32590           155.60001             2.77857

       5             0.00389           300.00000           300.32590           155.60001             2.77857

       6             0.00340          1000.00000          1006.18243           544.00000             5.44000

       7             0.00340          1000.00000          1006.18243           544.00000             5.44000

       8             0.00340          1000.00000          1006.18243           544.00000             5.44000

       9             0.00340          1000.00000          1006.18243           544.00000             5.44000

      10             0.00340          1000.00000          1006.18243           544.00000             5.44000

      11             0.00465          1500.00000          1495.30981          1162.50000             5.67073

      12             0.00465          1500.00000          1495.30981          1162.50000             5.67073

      13             0.00465          1500.00000          1495.30981          1162.50000             5.67073

      14             0.00465          1500.00000          1495.30981          1162.50000             5.67073

      15             0.00465          1500.00000          1495.30981          1162.50000             5.67073

      16            -0.00000            -0.00000
 * executing subroutine STIFF
 * executing subroutine SOLVE
1     WEIGHTING SEQUENCE


   BAND WIDTH    DIAGONAL VALUE
      1557    0.7237923622E+01
 * executing subroutine LOAD
1 DATA INTERVAL        0.02000



       INPUT ACCELERATIONS (ROWISE)     

       -2.0166537762       -3.0410516262       -3.2722671032       -1.2359132767       -1.4889023304
       -1.7429280281       -1.9057120085        0.9912191033        5.2049369812        5.0203795433
        6.4284081459        9.8416852951        9.6343183517       10.1558475494       10.6245002747
       10.2584953308        8.6959772110       10.1195583344       12.6940326691       12.3705377579
       10.8173522949        4.6823697090        1.2483555079       -3.2224986553       -9.9070072174
      -12.3902387619      -14.1933031082      -15.6905002594      -14.9584903717      -12.7790536880
       -9.2579441071       -2.5786211491       -0.8678351045        0.3649676740        7.8779101372
        7.4942793846        6.3319816589        4.5299539566        2.7279260159        0.6335092783
       -2.2675690651       -3.2950775623       -4.3225860596       -5.3490576744       -6.3765659332
       -7.4030380249       -8.9479293823      -11.9454345703      -13.9278717041      -16.1363410950
      -16.9751453400      -17.0352821350      -13.7827148438       -4.9996428490       -3.0949673653
        1.1446713209        5.6196727753        6.3558292389        7.4362168312        8.4015140533
        9.7981376648        9.5461864471        9.0609445572        8.0344734192        6.7684917450
        4.2365283966        0.8543562293       -0.6957196593       -2.4873790741       -6.0966196060
       -9.4331703186      -10.9687299728      -11.9941654205      -12.7469120026      -13.2757005692
      -12.6141958237      -10.1330375671       -9.3201541901       -7.4372534752       -5.4796996117
       -2.0166537762       -3.0410516262       -3.2722671032       -1.2359132767       -1.4889023304
       -1.7429280281       -1.9057120085        0.9912191033        5.2049369812        5.0203795433
        6.4284081459        9.8416852951        9.6343183517       10.1558475494       10.6245002747
       10.2584953308        8.6959772110       10.1195583344       12.6940326691       12.3705377579
       10.8173522949        4.6823697090        1.2483555079       -3.2224986553       -9.9070072174
      -12.3902387619      -14.1933031082      -15.6905002594      -14.9584903717      -12.7790536880
       -9.2579441071       -2.5786211491       -0.8678351045        0.3649676740        7.8779101372
        7.4942793846        6.3319816589        4.5299539566        2.7279260159        0.6335092783
       -2.2675690651       -3.2950775623       -4.3225860596       -5.3490576744       -6.3765659332
       -7.4030380249       -8.9479293823      -11.9454345703      -13.9278717041      -16.1363410950
      -16.9751453400      -17.0352821350      -13.7827148438       -4.9996428490       -3.0949673653
        1.1446713209        5.6196727753        6.3558292389        7.4362168312        8.4015140533
        9.7981376648        9.5461864471        9.0609445572        8.0344734192        6.7684917450
        4.2365283966        0.8543562293       -0.6957196593       -2.4873790741       -6.0966196060
       -9.4331703186      -10.9687299728      -11.9941654205      -12.7469120026      -13.2757005692
      -12.6141958237      -10.1330375671       -9.3201541901       -7.4372534752       -5.4796996117
 * executing subroutine INTPOL
 * executing subroutine REV
1    DECONVOLVED EARTHQUAKE
         1           140.09575
         2           173.34315
         3           210.05551
         4           223.75357
         5           235.93147
         6           164.30089
         7            91.88509
         8           101.83713
         9           109.13054
        10           120.15576
        11           128.07321
        12           130.06369
        13           135.00403
        14            36.84535
        15           -67.42120
        16          -211.25256
        17          -365.67957
        18          -354.35590
        19          -351.53214
        20          -397.57089
        21          -448.64566
        22          -562.72974
        23          -690.52594
        24          -676.55664
        25          -672.10767
        26          -684.15338
        27          -711.27185
        28          -718.16327
        29          -748.55743
        30          -725.15247
        31          -721.77075
        32          -660.94409
        33          -620.75201
        34          -658.20886
        35          -728.18402
        36          -788.15503
        37          -908.21899
        38          -866.64282
        39          -896.42609
        40          -814.35059
        41          -789.84088
        42          -529.97955
        43          -352.94910
        44          -188.07607
        45          -124.03970
        46            87.67209
        47           178.95554
        48           500.64920
        49           652.47906
        50           821.36914
        51           816.31604
        52           973.60797
        53           939.59412
        54          1109.24316
        55          1038.29211
        56          1144.81519
        57           973.60529
        58          1054.47131
        59           813.16895
        60           873.66595
        61           556.38879
        62           527.92755
        63            81.71781
        64           236.92397
        65           -47.56605
        66           159.96996
        67          -149.63684
        68          -128.71904
        69          -688.99969
        70          -376.74271
        71          -675.38904
        72          -295.87320
        73          -602.11133
        74          -189.01736
        75          -504.89941
        76           -45.95810
        77          -402.68533
        78           110.39165
        79          -276.22855
        80           279.04147
        81          -107.94469
        82           440.41559
        83           -49.47672
        84           529.64813
        85            -1.14902
        86           599.53992
        87            34.90140
        88           712.78217
        89          -179.07417
        90           733.48480
        91            99.55484
        92           883.12061
        93           235.89139
        94          1241.84216
        95           319.79813
        96          1196.37024
        97           511.88116
        98          1701.10181
        99           743.45569
       100          2094.84106
       101          1009.81451
       102          2143.02783
       103          1171.30566
       104          2063.67505
       105           814.31982
       106          1340.45459
       107          -170.01064
       108          1237.44507
       109          -191.65112
       110          1440.94714
       111          -310.71762
       112           316.12820
       113         -1535.88293
       114            16.52006
       115         -1342.62109
       116          -190.12573
       117         -1588.28906
       118          -680.71661
       119         -2340.46240
       120          -724.46582
       121         -2184.77197
       122          -652.63824
       123         -2068.16528
       124          -870.63306
       125         -2147.54419
       126          -847.01947
       127         -2182.24854
       128          -677.13855
       129         -1871.99841
       130          -778.04474
       131         -1948.77747
       132          -591.80640
       133         -1793.03064
       134          -738.14966
       135         -1720.07324
       136         -1417.63269
       137         -1973.88794
       138          -609.23651
       139          -842.02588
       140           188.54631
       141          -177.75261
       142           444.25162
       143           439.15070
       144          1284.36975
       145          2027.97351
       146          1608.94287
       147          2285.76709
       148          1918.99841
       149          2930.40503
       150          2239.59937
....
....
      1716********************

 
Upvote 0 Downvote
Here is the source I modified and it works for me
layer.for
Code: 
C     PROGRAM LAYER (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,TAPE1,TAPE2,    A   1
C    .        PUNCH)                                                       A   2
      PROGRAM LAYER                                                        A   1
                                                                           A   2
      COMMON NUMAT,DT,N,ALFA,BETA,HED(12),A(30000)                         A   3
C                                                                        LAYER.A   
C      ***** NOTICE TO USERS OF THIS SOFTWARE *****                      LAYER.B
C                                                                        LAYER.C
C      COPYRIGHT (C) 1971                                                LAYER.D
C      THE REGENTS OF THE UNIVERSITY OF CALIFORNIA (REGENTS)             LAYER.E
C      ALL RIGHTS RESERVED                                               LAYER.F
C                                                                        LAYER.G
C  IN NO EVENT SHALL REGENTS OF THE UNIVERSITY OF CALIFORNIA BE          LAYER.H
C  LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL,        LAYER.I
C  OR CONSEQUENTIAL DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF      LAYER.J
C  THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IT REGENTS       LAYER.K
C  HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                   LAYER.L
C                                                                        LAYER.M
C  REGENTS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT         LAYER.N
C  NOT LIMITED TO, THE IMPLIED WARRANTIES OR MERCHANTABILITY AND         LAYER.O
C  FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE AND ACCOMPANYING       LAYER.P
C  DOCUMENTATION, IF ANY, PROVIDED HEREUNDER IS PROVIDED "AS IS".        LAYER.Q
C  REGENTS HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT,            LAYER.R
C  UPDATES, ENHANCEMENTS, OR MODIFICATIONS.                              LAYER.S
C                                                                        LAYER.T
C                                                                          A   4
      open (5, file='tape5.dat', status='old')
      open (2, file='tape2.dat', status='unknown')      
  50  READ(5,1001) HED,NUMAT,IC,MPR,MP,ALFA,BETA                           A   5
      IF(NUMAT.EQ.0)  STOP                                                 A   6
      WRITE(6,2001)HED,NUMAT,IC,MPR,MP,ALFA,BETA                           A   7
      NUMAT=NUMAT-1                                                        A   8
      READ(5,1002) NUCAR,NPOINT,MMAX,NC,DT,FACT                            A   9
      IF (FACT.EQ.0.0)  FACT=1.0                                           A  10
      WRITE(6,2002) NUCAR,NPOINT,MMAX,NC,DT,FACT                           A  11
      N1=1                                                                 A  12
      N2=N1+NUMAT                                                          A  13
      N3=N2+NUMAT                                                          A  14
      N4=N3+NUMAT                                                          A  15
C                                                                          A  16
      CALL DISCRT (A(N1),A(N2),A(N3),A(N4))                                A  17
      N5=N4+NUMAT                                                          A  18
      N6=N5+N                                                              A  19
      CALL STIFF (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),N)                   A  20
      N2=N1+N                                                              A  21
      N3=N2+2*N                                                            A  22
      N4=N3+N                                                              A  23
      N5=N4+N                                                              A  24
      N6=N5+N                                                              A  25
      N7=N6+N                                                              A  26
      N8=N7+N                                                              A  27
      CALL SOLVE (A(N1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),N,       A  28
     .            MMAX,NMAX,MP,MPR)                                        A  29
      NM=MMAX+NMAX-1                                                       A  30
      N2=N1+NM                                                             A  31
      N3=N2+MMAX                                                           A  32
      N4=N3+NPOINT                                                         A  33
      CALL LOAD (A(N2),A(N3),A(N4),NUCAR,MMAX,NC,DT,FACT)                  A  34
      IF(IC.EQ.0)  GO TO 70                                                A  35
      CALL CONV(A(N1),A(N2),MMAX,MP)                                       A  36
      GO TO 50                                                             A  37
   70 IF(ALFA.EQ.0.0.AND.BETA.EQ.0.0)  GO TO 80                            A  38
      CALL GESOL (A(N1),A(N2),A(N3),NMAX,MMAX)                             A  39
      GO TO 50                                                             A  40
   80 CALL REV (A(N1),A(N2),A(N3),NM)                                      A  41
      GO TO 50                                                             A  42
C                                                                          A  43
 1001 FORMAT (12A6/4I5,2F10.0)                                             A  44
 1002 FORMAT (4I5,2F10.0)                                                  A  45
 2001 FORMAT (1H1,12A6///                                                  A  46
     .  20H NUMBER OF MATERIALS ,I5/                                       A  47
     .  20H SOLUTION CODE      ,I5/                                        A  48
     .  20H EQ 0 DECONVOLUTION    /                                        A  49
     .  20H EQ 1 CONVOLUTION      /                                        A  50
     .  20H PRINT CODE         ,I5/                                        A  51
     .  21H EQ 1 WGT.SEQ.PRINTED   /                                       A  52
     .  21H EQ 0 NOT PRINTED       /                                       A  53
     .  20H PUNCH CODE         ,I5/                                        A  54
     .  21H EQ 1 WGT.SEQ.PUNCHED   /                                       A  55
     .  21H EQ 0 NOT PUNCHED       /                                       A  56
     3  22H DAMPING COEFF. (ALFA) ,F10.6/                                  A  57
     4  22H DAMPING COEFF. (BETA) ,F10.6/////)                             A  58
 2002 FORMAT (21H NUMBER OF ACC. CARDS ,I5/                                A  59
     .        21H NUMBER OF DEF. POINT ,I5/                                A  60
     .        21H NUMBER OF TIME STEPS ,I5/                                A  61
     .        20H INPUT CONDITION      ,I5/                                A  62
     .        20H TIME INCREMENT       ,F10.5/                             A  63
     .        20H FUNCTION MULTIPLIER  ,F10.5/////)                        A  64
      close(5)
      close(2)
      END                                                                  A  65
      SUBROUTINE DISCRT (SMU,SMOD,H,NBOUN)                                 B   1
      COMMON NUMAT,DT,N,ALFA,BETA,DHS                                      B   2
      DIMENSION SMU(1),SMOD(1),H(1),NBOUN(1)                               B   3
C                                                                          B   4
      write (*,*) '* executing subroutine DISCRT'
      WRITE(6,3000)                                                        B   5
      NJ=1                                                                 B   6
      DO 50 I=1,NUMAT                                                      B   7
      READ (5,1001) MAT,SMU(MAT),SMOD(MAT),H(MAT)                          B   8
      C=SQRT(SMOD(I)/SMU(I))                                               B   9
      CC=C*DT                                                              B  10
      SN=H(I)/CC                                                           B  11
      IF (SN.LE.0.5)  SN=1.0                                               B  12
      NS=SN                                                                B  13
      IF ((SN-NS).GE.0.5)  NS=NS+1                                         B  14
      NJ=NJ+NS                                                             B  15
      NBOUN(I)=NJ                                                          B  16
      SM=SMOD(I)                                                           B  17
      SMOD(I)=(H(I)*H(I)*SMU(I))/(NS*NS*DT*DT)                             B  18
      DX=SQRT(SMOD(I)/SMU(I))*DT                                           B  19
      WRITE(6,2001)MAT,SMU(MAT),SM,SMOD(MAT),H(MAT),DX                     B  20
      H(I)=DX                                                              B  21
   50 CONTINUE                                                             B  22
      N=NBOUN(NUMAT)                                                       B  23
      READ(5,1001) MAT,SMUH,SMODH                                          B  24
C     DHS=1.0E+100                                                         B  25
      DHS=1.0E+38                                                          B  25
      IF(SMUH.EQ.0.0)  GO TO 60                                            B  26
      DHS=SMUH*SQRT(SMODH/SMUH)                                            B  27
   60 WRITE(6,2001) MAT,SMUH,SMODH                                         B  28
C                                                                          B  29
      RETURN                                                               B  30
 1001 FORMAT(I5,3F10.0)                                                    B  31
 2001 FORMAT(I8,5F20.5/)                                                   B  32
 3000 FORMAT(1H ,5X,5HLAYER,12X,4HMASS,11X,10HSHEAR MOD.,9X,13HMODIFIED    B  33
     .MOD.,9X,12HLAYER THICK.,6X,15HSUBLAYER THICK.,//)                    B  34
      END                                                                  B  35
      SUBROUTINE STIFF (SMU,SMOD,H,NBOUN,SMASS,A,N)                        C   1
      DIMENSION SMU(1),SMOD(1),H(1),NBOUN(1),SMASS(N),A(N,2)               C   2
C***********************************************************************   C   3
C   FORM STIFFNESS AND MASS MATRICES                                       C   4
C***********************************************************************   C   5
      write (*,*) '* executing subroutine STIFF'
      N1=N-1                                                               C   6
      L=1                                                                  C   7
      K=2                                                                  C   8
      NB=NBOUN(1)                                                          C   9
      SK2=-SMOD(1)/H(1)                                                    C  10
      SK1=-2.0*SK2                                                         C  11
      SM=SMU(1)*H(1)                                                       C  12
      A(1,1)=SK1/2.0                                                       C  13
      A(1,2)=SK2                                                           C  14
      SMASS(1)=SM/2.0                                                      C  15
      IF(N.EQ.2)  GO TO 40                                                 C  16
      DO 50 I=2,N1                                                         C  17
      IF(I.EQ.NB)  GO TO 60                                                C  18
      A(I,1)=SK1                                                           C  19
      A(I,2)=SK2                                                           C  20
      SMASS(I)=SM                                                          C  21
      GO TO 50                                                             C  22
   60 SK1=SMOD(L)/H(L)                                                     C  23
      SK2=SMOD(K)/H(K)                                                     C  24
      SM2=SMU(K)*H(K)                                                      C  25
      A(I,1)=SK1+SK2                                                       C  26
      A(I,2)=-SK2                                                          C  27
      SMASS(I)=(SM+SM2)/2.0                                                C  28
      SK1=2.0*SK2                                                          C  29
      SK2=-SK2                                                             C  30
      SM=SM2                                                               C  31
      L=L+1                                                                C  32
      K=K+1                                                                C  33
      NB=NBOUN(L)                                                          C  34
   50 CONTINUE                                                             C  35
   40 A(N,1)=-SK2                                                          C  36
      SMASS(N)=SM/2.0                                                      C  37
      A(N,2)=0.0                                                           C  38
C                                                                          C  39
      REWIND 2                                                             C  40
C     WRITE (2) SMASS,A                                                    C  41
      write (2,*) SMASS,A
C                                                                          C  42
      RETURN                                                               C  43
      END                                                                  C  44
      SUBROUTINE SOLVE (SMASS,A,X0,X1,X2,B,MAXB,G,N,NUACC,NMAX, MP,MPR)    D   1
      COMMON NUMAT,DT,N1,ALFA,BETA,DHS                                     D   2
      DIMENSION SMASS(N),A(N,2),X0(1),X1(1),X2(1),B(1),MAXB(1),G(1)        D   3
C                                                                          D   4
      write (*,*) '* executing subroutine SOLVE'
      REWIND 2                                                             D   5
C     READ (2) SMASS,A                                                     D   6
      read (2,*) SMASS,A
C                                                                          D   7
C***********************************************************************   D   8
C   INITIAL CONDITIONS                                                     D   9
C***********************************************************************   D  10
      WRITE (6,3000)                                                       D  11
      NT=0                                                                 D  12
      NTOT=NUACC+N                                                         D  13
      DO 100 I=1,N                                                         D  14
      X0(I)=0.                                                             D  15
      X1(I)=0.                                                             D  16
  100 X2(I)=0.                                                             D  17
      IF(BETA.NE.0.0)  GO TO 75                                            D  18
      A1=DT*DT/2.                                                          D  19
      A2=2./(ALFA*DT*DT+2.*DT)                                             D  20
      A3=DT/(ALFA*DT+2.)                                                   D  21
      A4=2./DT                                                             D  22
      A5=1./A3                                                             D  23
      E1=SMASS(N)/(SMASS(N)*A5+DHS)                                        D  24
      E2=E1/A1                                                             D  25
      NLS=N-1                                                              D  26
      DO 177 I=1,NLS                                                       D  27
  177 SMASS(I)=A5*SMASS(I)                                                 D  28
      SMASS(N)=A5*SMASS(N)+DHS                                             D  29
      GO TO 175                                                            D  30
   75 A0=ALFA+2./DT                                                        D  31
      A1=DT*DT/2.                                                          D  32
      A2=2./(DT*DT)+ALFA/BETA+2./(BETA*DT)                                 D  33
      A3=2./(DT*DT)                                                        D  34
      A4=1./BETA                                                           D  35
      A5=2./DT                                                             D  36
      A6=DHS/BETA                                                          D  37
      DO 150 I=1,N                                                         D  38
      A(I,1)=A0*SMASS(I)+BETA*A(I,1)                                       D  39
  150 A(I,2)=BETA*A(I,2)                                                   D  40
      A(N,1)=A(N,1)+DHS                                                    D  41
      GO TO 200                                                            D  42
C***********************************************************************   D  43
C   NUMERICAL INTEGRATION AND STORE WEIGHTING SEQUENCE                     D  44
C***********************************************************************   D  45
  175 BAC=0.                                                               D  46
      IF(NT.EQ.0) BAC=2.                                                   D  47
      DO 180 I=1,N                                                         D  48
      TEMP=DT*X1(I)+A1*X2(I)                                               D  49
      VEL=A2*TEMP                                                          D  50
      X2(I)=A4*X1(I)+X2(I)                                                 D  51
      X1(I)=VEL-A3*BAC                                                     D  52
  180 X0(I)=X0(I)+TEMP                                                     D  53
      X1(N)=E2*TEMP-E1*BAC                                                 D  54
      CALL MULT (A,X0,B,N,2)                                               D  55
      DO 190 I=1,N                                                         D  56
      X1(I)=X1(I)-B(I)/SMASS(I)                                            D  57
  190 X2(I)=A4*X1(I)-X2(I)                                                 D  58
      GO TO 325                                                            D  59
  200 CALL TRIA(N,2,A,MAXB)                                                D  60
  275 IF(BETA.EQ.0.0)  GO TO 175                                           D  61
      BAC=0.                                                               D  62
      IF(NT.EQ.0) BAC=2.                                                   D  63
      DO 250 I=1,N                                                         D  64
      DIS=X0(I)+DT*X1(I)+A1*X2(I)                                          D  65
      B(I)=-BAC*SMASS(I)+SMASS(I)*(A2*DIS-A3*X0(I))                        D  66
  250 X0(I)=DIS                                                            D  67
      B(N)=B(N)+A6*X0(N)                                                   D  68
      CALL BACKS(N,2,A,MAXB,B)                                             D  69
      DO 300 I=1,N                                                         D  70
      VEL=B(I)-A4*X0(I)                                                    D  71
      X2(I)=A5*(VEL-X1(I))-X2(I)                                           D  72
  300 X1(I)=VEL                                                            D  73
  325 NT=NT+1                                                              D  74
      G(NT)=X2(1)+BAC                                                      D  75
      IF(MPR) 330,335,330                                                  D  76
  330 WRITE (6,2000) NT,G(NT)                                              D  77
  335 IF(NT.LT.NTOT)  GO TO 275                                            D  78
C     IF(MP.EQ.1) PUNCH 2001, (G(K), K=1,NTOT)                             D  79
      IF(MP.EQ.1) WRITE(6,2001) (G(K), K=1,NTOT)                           D  79
      GMAX=G(N)/500.                                                       D  80
      DO 400 I=1,NTOT                                                      D  81
  400 IF(ABS(G(I)).LT.GMAX)  G(I)=0.                                       D  82
      DO 410 I=1,NTOT                                                      D  83
      IF(G(I).EQ.0.0)  GO TO 410                                           D  84
      KX=I-1                                                               D  85
      GO TO 420                                                            D  86
  410 CONTINUE                                                             D  87
  420 NTG=NTOT-KX                                                          D  88
      DO 425 I=1,NTG                                                       D  89
  425 SMASS(I)=G(I+KX)                                                     D  90
      NMAX=N-KX                                                            D  91
      WRITE(6,3001)                                                        D  92
      WRITE (6,2000) NMAX,SMASS(NMAX)                                      D  93
C                                                                          D  94
      RETURN                                                               D  95
 2000 FORMAT (I10,E20.10)                                                  D  96
 2001 FORMAT(4E20.14)                                                      D  97
 3000 FORMAT(1H1,5X,18HWEIGHTING SEQUENCE)                                 D  98
 3001 FORMAT(//,3X,10HBAND WIDTH,4X,14HDIAGONAL VALUE)                     D  99
      END                                                                  D 100
      SUBROUTINE TRIA(NEQ,MBAND,A,NBMAX)                                   E   1
      DIMENSION A(1),NBMAX(1)                                              E   2
C                                                                          E   3
C     TRIANGULARIZE BANDED MATRIX BY GAUSS ELIMINATION                     E   4
C                                                                          E   5
      write (*,*) '* executing subroutine TRIA'
      IF(NEQ.EQ.1)RETURN                                                   E   6
      MM=NEQ*MBAND                                                         E   7
      NE=NEQ-1                                                             E   8
      DO 300 N=1,NE                                                        E   9
C                                                                          E  10
C     DETERMINE EQUATION LENGTH                                            E  11
C                                                                          E  12
      NBMAX(N)=0                                                           E  13
      DO 100 I=N,MM,NEQ                                                    E  14
      IF(A(I).NE.0.0) NBMAX(N)=I                                           E  15
  100 CONTINUE                                                             E  16
      IF (A(N).EQ.0.0)  GO TO 300                                          E  17
C                                                                          E  18
C     SUBSTITUTE INTO EQUATIONS WITHIN BAND                                E  19
C                                                                          E  20
      IL=N+NEQ                                                             E  21
      IH=NBMAX(N)                                                          E  22
      L=N                                                                  E  23
      DO 200 I=IL,IH,NEQ                                                   E  24
      L=L+1                                                                E  25
      IF(A(I).EQ.0.0)  GO TO 200                                           E  26
      C=A(I)/A(N)                                                          E  27
      J=L-I                                                                E  28
      DO 50 K=I,IH,NEQ                                                     E  29
   50 A(K+J)=A(K+J)-C*A(K)                                                 E  30
      A(I)=C                                                               E  31
  200 CONTINUE                                                             E  32
  300 CONTINUE                                                             E  33
C                                                                          E  34
      RETURN                                                               E  35
      END                                                                  E  36
      SUBROUTINE BACKS(NEQ,MBAND,A,NBMAX,B)                                F   1
      DIMENSION A(1),B(1),NBMAX(1)                                         F   2
      write (*,*) '* executing subroutine BACKS'
      IL=NEQ                                                               F   3
C                                                                          F   4
      DO 400 N=1,NEQ                                                       F   5
      C=B(N)                                                               F   6
      IF(A(N).NE.0.0)  B(N)=B(N)/A(N)                                      F   7
      IF(N.EQ.NEQ)  GO TO 450                                              F   8
      IL=IL+1                                                              F   9
      IH=NBMAX(N)                                                          F  10
      K=N                                                                  F  11
      DO 350 I=IL,IH,NEQ                                                   F  12
      K=K+1                                                                F  13
  350 B(K)=B(K)-A(I)*C                                                     F  14
  400 CONTINUE                                                             F  15
C                                                                          F  16
  450 IL=2*NEQ                                                             F  17
  500 IL=IL-1                                                              F  18
      N=N-1                                                                F  19
      IF(N.EQ.0)  RETURN                                                   F  20
      IH=NBMAX(N)                                                          F  21
      K=N                                                                  F  22
      DO 600 I=IL,IH,NEQ                                                   F  23
      K=K+1                                                                F  24
  600 B(N)=B(N)-A(I)*B(K)                                                  F  25
C                                                                          F  26
      GO TO 500                                                            F  27
C                                                                          F  28
      END                                                                  F  29
      SUBROUTINE MULT (A,B,C,NEQ,MB)                                       G   1
      DIMENSION A(NEQ,1),B(1),C(1)                                         G   2
C                                                                          G   3
C     write (*,*) '* executing subroutine MULT'
      NN=NEQ-MB+1                                                          G   4
      MX=MB                                                                G   5
C                                                                          G   6
      DO 200 N=1,NEQ                                                       G   7
      C(N)=0.0                                                             G   8
      IF(N.GT.NN)  MX=MX-1                                                 G   9
      N1=N-1                                                               G  10
      DO 100 J=1,MX                                                        G  11
  100 C(N)=C(N)+A(N,J)*B(J+N1)                                             G  12
  200 CONTINUE                                                             G  13
      IF(NEQ.EQ.1)  RETURN                                                 G  14
C                                                                          G  15
      DO 400 N=2,NEQ                                                       G  16
      IF(N.LE.MB)  MX=N                                                    G  17
      N1=N+1                                                               G  18
      DO 300 J=2,MX                                                        G  19
  300 C(N)=C(N)+A(N1-J,J)*B(N1-J)                                          G  20
  400 CONTINUE                                                             G  21
C                                                                          G  22
      RETURN                                                               G  23
      END                                                                  G  24
      SUBROUTINE LOAD (A,T,AC,NUCAR,MMAX,NC,DX,FACT)                       H   1
      DIMENSION A(MMAX),T(1),AC(1)                                         H   2
      write (*,*) '* executing subroutine LOAD'
      IF(NC.NE.1)  GO TO 10                                                H   3
      WRITE(6,3001)                                                        H   4
      DO 100 I=1,NUCAR                                                     H   5
      READ(5,1001) T(I),AC(I)                                              H   6
      AC(I)=FACT*AC(I)                                                     H   7
      WRITE(6,2001) T(I),AC(I)                                             H   8
  100 CONTINUE                                                             H   9
      GO TO 40                                                             H  10
   10 IF(NC.NE.2)  GO TO 20                                                H  11
      WRITE(6,3002)                                                        H  12
      K=1                                                                  H  13
      DO 200 I=1,NUCAR                                                     H  14
      KK = 5*I                                                             H  15
      READ(5,1002) (T(J),AC(J),J=K,KK)                                     H  16
      WRITE(6,2002) (T(J),AC(J),J=K,KK)                                    H  17
  200 K=KK+1                                                               H  18
      NUCAR=6*NUCAR                                                        H  19
      DO 250 I=1,NUCAR                                                     H  20
  250 AC(I)=FACT*AC(I)                                                     H  21
      GO TO 40                                                             H  22
   20 IF(NC.NE.3)  GO TO 50                                                H  23
      READ(5,1003) DT                                                      H  24
      WRITE(6,2003) DT                                                     H  25
      WRITE(6,3004)                                                        H  26
      NUCAR=8*NUCAR                                                        H  27
      T(1)=0.0                                                             H  28
      DO 300 I=2,NUCAR                                                     H  29
  300 T(I)=T(I-1)+DT                                                       H  30
C     READ (5,1004) (AC(I),I=1,NUCAR)                                      H  31
      read (5,*) (AC(I),I=1,NUCAR)
      DO 350 I=1,NUCAR                                                     H  32
  350 AC(I)=FACT*AC(I)                                                     H  33
      WRITE (6,2004) (AC(I),I=1,NUCAR)                                     H  34
   40 CALL INTPOL (T,AC,MMAX,DX,A)                                         H  35
      GO TO 500                                                            H  36
   50 READ(5,1004) (A(I),I=1,MMAX)                                         H  37
      WRITE(6,3005)                                                        H  38
      DO 400 I=1,MMAX                                                      H  39
  400 A(I)=FACT*A(I)                                                       H  40
      WRITE(6,2004) (A(I),I=1,MMAX)                                        H  41
C                                                                          H  42
  500 CONTINUE                                                             H  43
C                                                                          H  44
      RETURN                                                               H  45
 1001 FORMAT(2F10.0)                                                       H  46
 1002 FORMAT(5(F7.3,F7.3))                                                 H  47
 1003 FORMAT(F10.0)                                                        H  48
 1004 FORMAT (8F9.0)                                                       H  49
 2001 FORMAT (F8.4,10X,F12.8)                                              H  50
 2002 FORMAT(5(F7.3,F7.3))                                                 H  51
 2003 FORMAT (20H1 DATA INTERVAL      ,F10.5///)                           H  52
 2004 FORMAT (5F20.10)                                                     H  53
 3001 FORMAT(40H1     TIME          INPUT ACCELERATIONS  ///)              H  54
 3002 FORMAT(1H1,32HTIMES AND ACCELERATIONS AS INPUT,/,                    H  55
     1  58HTIME  ACCL  TIME  ACCL  TIME  ACCL  TIME  ACCL  TIME  ACCL)     H  56
 3004 FORMAT (    40H       INPUT ACCELERATIONS (ROWISE)      /)           H  57
 3005 FORMAT (1H1,40H       INPUT ACCELERATIONS (ROWISE)      /)           H  58
      END                                                                  H  59
      SUBROUTINE INTPOL (X, Y, MMAX, DX, A)                                I   1
C                                                                          I   2
C     SUBROUTINE TO INTERPOLATE A FUNCTION AT EQUAL INTERVALS OF X COORD   I   3
C                                                                          I   4
      DIMENSION X(1),Y(1),A(1)                                             I   5
      write (*,*) '* executing subroutine INTPOL'
      N = 2                                                                I   6
      A(1) = Y(1)                                                          I   7
      X1 = X(1)                                                            I   8
      DO 300 M = 2, MMAX                                                   I   9
      EM = M                                                               I  10
      GO TO 304                                                            I  11
  301 N = N + 1                                                            I  12
  304 B = (EM-1.0)*DX - X(N-1) + X1                                        I  13
      C = X(N) - X(N-1)                                                    I  14
      IF (C-B) 301,302,303                                                 I  15
  302 A(M) = Y(N)                                                          I  16
      GO TO 300                                                            I  17
  303 SLOPE = (Y(N) - Y(N-1)) / C                                          I  18
      A(M) = Y(N-1) + B*SLOPE                                              I  19
C                                                                          I  20
  300 CONTINUE                                                             I  21
      RETURN                                                               I  22
      END                                                                  I  23
      SUBROUTINE CONV (G,F,NT, MP)                                         J   1
      DIMENSION G(1),F(1), STO(4)                                          J   2
      write (*,*) '* executing subroutine CONV'
      WRITE (6,3000)                                                       J   3
      KS = 0                                                               J   4
      DO 200 K=1,NT                                                        J   5
      H=0.0                                                                J   6
      K1=K+1                                                               J   7
      KS = KS + 1                                                          J   8
      DO 100 I=1,K                                                         J   9
  100 H=H+F(I)*G(K1-I)                                                     J  10
      IF(MP.EQ.0) GO TO 200                                                J  11
      STO(KS) = H                                                          J  12
      IF(KS.NE.4) GO TO 200                                                J  13
C     PUNCH 2001, STO                                                      J  14
      WRITE(6,2001) STO                                                    J  14
      KS = 0                                                               J  15
  200 WRITE(6,2000) K,H                                                    J  16
C                                                                          J  17
      RETURN                                                               J  18
 2000 FORMAT(I10,F10.5)                                                    J  19
 2001 FORMAT(4E20.14)                                                      J  20
 3000 FORMAT (30H1 CONVOLVED EARTHQUAKE             )                      J  21
      END                                                                  J  22
      SUBROUTINE GESOL (TF,B,A,MBAND,NN)                                   K   1
      DIMENSION TF(1),B(1),A(MBAND,1)                                      K   2
C                                                                          K   3
      write (*,*) '* executing subroutine GESOL'
      REWIND 1                                                             K   4
      MB1=MBAND-1                                                          K   5
      NN1=NN+1                                                             K   6
      NN2=NN/2                                                             K   7
      DO 50 I=1,NN2                                                        K   8
      TEMP=B(I)                                                            K   9
      II=NN1-I                                                             K  10
      B(I)=B(II)                                                           K  11
   50 B(II)=TEMP                                                           K  12
C                                                                          K  13
       DO 100 I=1,MBAND                                                    K  14
      MB=MBAND-I                                                           K  15
      DO 100 J=1,NN                                                        K  16
      K=MB+J                                                               K  17
  100 A(I,J)=TF(K)                                                         K  18
C                                                                          K  19
      DO 475 N=1,NN                                                        K  20
      N2=N-1                                                               K  21
      N1=N+1                                                               K  22
      B(N)=B(N)/A(1,N)                                                     K  23
      IF(N.EQ.NN)  GO TO 490                                               K  24
      DO 250 J=N1,NN                                                       K  25
      IF(A(1,J).EQ.0.0)  GO TO 250                                         K  26
      A(1,J)=A(1,J)/A(1,N)                                                 K  27
      C=A(1,J)                                                             K  28
      DO 260 I=2,MBAND                                                     K  29
  260 A(I,J)=A(I,J)-A(I,N)*C                                               K  30
  250 CONTINUE                                                             K  31
C                                                                          K  32
      DO 300 I=2,MBAND                                                     K  33
      II=I+N2                                                              K  34
  300 B(II)=B(II)-A(I,N)*B(N)                                              K  35
      WRITE (1) (A(1,J),J=N1,NN)                                           K  36
      DO 400 I=1,MB1                                                       K  37
      I1=I+1                                                               K  38
      DO 400 J=N1,NN                                                       K  39
  400 A(I,J)=A(I1,J)                                                       K  40
C                                                                          K  41
      K=0                                                                  K  42
      DO 450 J=N1,NN                                                       K  43
      K=K+1                                                                K  44
  450 A(MBAND,J)=TF(K)                                                     K  45
  475 CONTINUE                                                             K  46
C                                                                          K  47
  490 BACKSPACE 1                                                          K  48
  500 N1=N                                                                 K  49
      N=N-1                                                                K  50
      IF(N.EQ.0)  GO TO 700                                                K  51
      READ (1) (A(1,J),J=N1,NN)                                            K  52
      BACKSPACE 1                                                          K  53
      BACKSPACE 1                                                          K  54
      DO 600 J=N1,NN                                                       K  55
  600 B(N)=B(N)-A(1,J)*B(J)                                                K  56
      GO TO 500                                                            K  57
  700 DO 800 I=1,NN2                                                       K  58
      TEMP=B(I)                                                            K  59
      II=NN1-I                                                             K  60
      B(I)=B(II)                                                           K  61
  800 B(II)=TEMP                                                           K  62
      WRITE (6,3000)                                                       K  63
      WRITE (6,2000) (I,B(I),I=1,NN)                                       K  64
C                                                                          K  65
      RETURN                                                               K  66
 2000 FORMAT (I10,F20.5)                                                   K  67
 3000 FORMAT(1H1,4X,22HDECONVOLVED EARTHQUAKE)                             K  68
      END                                                                  K  69
      SUBROUTINE REV (G,US,UB,NT)                                          L   1
      DIMENSION US(1),G(1),UB(NT)                                          L   2
      write (*,*) '* executing subroutine REV'
      NT1=NT-1                                                             L   3
      DO 100 N=1,NT1                                                       L   4
      UB(N)=US(N)/G(1)                                                     L   5
      IF (N.EQ.NT)  GO TO 100                                              L   6
      N1=N+1                                                               L   7
      DO 200 I=N1,NT                                                       L   8
      II=I-N+1                                                             L   9
  200 US(I)=US(I)-UB(N)*G(II)                                              L  10
  100 CONTINUE                                                             L  11
      UB(NT)=US(NT)/G(1)                                                   L  12
      WRITE (6,3000)                                                       L  13
      WRITE (6,2000) (I,UB(I),I=1,NT)                                      L  14
C                                                                          L  15
      RETURN                                                               L  16
 2000 FORMAT (I10,F20.5)                                                   L  17
 3000 FORMAT(1H1,4X,22HDECONVOLVED EARTHQUAKE)                             L  18
      END                                                                  L  19
It compiles with
Code: 
$ gfortran layer.for -o layer
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

joeyc100
  • Locked
  • Question
f1042 error during compile
Replies
9
Views
427
joeyc100
joeyc100
R
  • Locked
  • Question
How do I print a real number using GNU gfortran
Replies
3
Views
423
rdflg
R
ksqr
  • Locked
  • Question
Looking for a Fortran 77 or newer compiler fo PC 1
2
Replies
28
Views
1K
xwb
xwb
AlanJT
  • Locked
  • Question
I have developed a program using th
Replies
4
Views
157
AlanJT
AlanJT
hasnaoui
  • Locked
  • Question
Thank you very much for your help.
Replies
1
Views
302
mikrom
mikrom

Part and Inventory Search

Sponsor

Back
Top