-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathreg1st.F
216 lines (216 loc) · 7.78 KB
/
reg1st.F
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
subroutine reg1st (nunit, wrform, wrvol, wrk, wrmask, rmask)
#if defined tracer_averages || defined term_balances
c
c=======================================================================
c
c Subroutine reg1st is i/o routine for the user defined horizontal
c and vertical regional masks used in MOM.
c It is also the i/o routine that can be used to write volume
c information for the horizontal regions used in calculating
c volume weighted averages of tracers and surface tracer fluxes.
c Both formatted and unformatted i/o is supported.
c (see "cregin.h" for more details on variables).
c
c when "readrmsk" is defined, "mskhr","mskvr", "hregnm" &"vregnm"
c will be read from file "regionmasks" which is assigned to
c "iormsk" in the same manner as this routine writes that
c information. ("iormsk" is set in "blkdta.F")
c alternatively, the horizontal region masks can be specified in
c "setocn.F", and although a simple, latitude dependent default
c setting is provided, the user should consider specifying a more
c appropriate set of masks.
c
c author: k. dixon e-mail=> kd@gfdl.gov
c
c=======================================================================
c
#include "param.h"
#include "cregin.h"
#include "iounit.h"
c
c nunit = unit to be written to or read from
c wrform= true(false) switch for formatted(unformatted) writes
c wrvol = switch to write volume & area information
c wrk = switch to write k-level volume information
c wrmask= switch to write horizontal region masks field
c rmask = switch to read horizontal region masks field from specified
c unit
c settop, setbot are used in defining level limits for vertical regions
c
logical wrform, wrvol, wrk, wrmask, rmask
logical settop, setbot
c
dimension ncol(imt)
c
c-----------------------------------------------------------------------
c write out regional volume information
c-----------------------------------------------------------------------
c
if (wrvol) then
if(wrform) then
write(nunit,9000)
if(wrk) then
write(nunit,9001) (mask,mask=1,nhreg)
do 700 k=1,km
write(nunit,9002) k, volgk(k),
$ (volbk(mask,k),mask=1,nhreg)
700 continue
endif
write(nunit,9003) volgt, (volbt(mask),mask=1,nhreg)
write(nunit,9004) areag, (areab(mask),mask=1,nhreg)
else
c
iotext ='read (iotavg) km, nhreg, volgt, areag'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
write (nunit) km, nhreg, volgt, areag
c
iotext ='read (iotavg) (volgk(k),k=1,km)'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
call wrufio (nunit, volgk, km)
c
iotext ='read (iotavg) ((volbk(l,k),l=1,nhreg),k=1,km)'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
call wrufio (nunit, volbk, nhreg*km)
c
iotext ='read (iotavg) (volbt(l),l=1,nhreg)'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
call wrufio (nunit, volbt, nhreg)
c
iotext ='read (iotavg) (areab(l),l=1,nhreg)'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
call wrufio (nunit, areab, nhreg)
endif
endif
c
c-----------------------------------------------------------------------
c read in (write out) horizontal & vertical region masks
c set linel to length of desired formatted printout line
c-----------------------------------------------------------------------
c
if (wrmask .or. rmask) then
c
if(wrform) then
if (wrmask) write(nunit,9011)
if (wrmask) write(nunit,9012)
$ (' domain for hor mask #',i,'=',hregnm(i),i=1,nhreg)
if ( rmask) then
read (nunit,9099)
read (nunit,9099)
endif
if ( rmask) read (nunit,9013) (hregnm(i),i=1,nhreg)
if (nunit .eq. stdout) then
call iplot (mskhr, imt, imt, jmt)
else
linemx = 100
linel = 105
line = linel - 5
if (line .gt. linemx) line = linemx
nwr = (imt/line) + 1
c
do 900 i=1,imt
ncol(i) = mod(i,10)
900 continue
c
do 1000 n=1,nwr
ia = 1 + (line*(n-1))
ib = ia + line - 1
if (ib .gt. imt) ib = imt
if (wrmask) write(nunit,9021) (ncol(i),i=ia,ib)
if ( rmask) read (nunit,9099)
do 990 jj=1,jmt
jjj = jmt - jj + 1
if (wrmask)write(nunit,9022)jjj,(mskhr(i,jjj),i=ia,ib)
if ( rmask) then
read (nunit,9022) jr , (mskhr(i,jjj),i=ia,ib)
if (jr .ne. jjj) then
write (stdout,999) nunit, jjj, jr
write (stderr,999) nunit, jjj, jr
stop '=>reg1st'
endif
endif
990 continue
1000 continue
endif
c
if (wrmask) write(nunit,9031)
if (wrmask) write(nunit,9032)
$ (' domain for ver mask #',i,'=',vregnm(i),i=1,nvreg)
if (wrmask) write(nunit,9034) mskvr
c
if ( rmask) then
read (nunit,9099)
read (nunit,9099)
endif
if ( rmask) read (nunit,9033) (vregnm(i),i=1,nvreg)
if ( rmask) read (nunit,9034) mskvr
c
else
if (wrmask) then
iotext = ' read (nunit) mskhr, mskvr'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
write(nunit) mskhr, mskvr
c
iotext = ' read (nunit) hregnm, vregnm'
write (nunit) 'no stamp available in reg1st ', iotext
$, expnam
write(nunit) hregnm, vregnm
endif
if (rmask) then
read (nunit)
read (nunit) mskhr, mskvr
read (nunit)
read (nunit) hregnm, vregnm
endif
endif
endif
c
c if vertical masks were read in, set level limits for defining
c vertical regions in term balance calculations
c
if (rmask) then
do 1100 i=1,nvreg
settop = .false.
setbot = .false.
do 1090 k=1,km
kk = km-k+1
if (mskvr(k) .eq. i .and. .not. settop) then
llvreg(i,1) = k
settop = .true.
endif
if (mskvr(kk) .eq. i .and. .not. setbot) then
llvreg(i,2) = kk
setbot = .true.
endif
1090 continue
1100 continue
endif
return
c
999 format(/' error => bad j-row when reading regionmasks from unit ',
$ i3,/' expected',i4,' read in',i4)
9000 format(/' Horizontal regional volumes [cubic m] and areas [sq m]')
9001 format(' k',' All Regions ',9(1x,i7,5x))
9002 format(1x,i4,10(1x,e12.6))
9003 format(' SUM',10(1x,e12.6))
9004 format(/' AREA',10(1x,e12.6))
9011 format(/' Horizontal regional mask names & domains:')
9012 format(a22,i4,a1,a40)
9013 format(27x,a40)
9021 format(' i=>',100(i1))
9022 format(1x,i3,1x,100(i1))
9031 format(/' Vertical regional mask names & domains:')
9032 format(a22,i4,a1,a20)
9033 format(27x,a20)
9034 format (1x, 42i3)
9099 format(1x)
end
#else
return
end
#endif