/[MITgcm]/MITgcm_contrib/mlosch/optim_m1qn3/optim_writedata.F
ViewVC logotype

Contents of /MITgcm_contrib/mlosch/optim_m1qn3/optim_writedata.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.5 - (show annotations) (download)
Thu May 3 11:26:05 2018 UTC (2 years ago) by mlosch
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +89 -106 lines
spring cleaning

- adjust some debugging output
- reduce amount of output
- code cleaning (mainly indentation) for better readability

1 C $Header: /u/gcmpack/MITgcm_contrib/mlosch/optim_m1qn3/optim_writedata.F,v 1.4 2016/05/09 09:37:17 mlosch Exp $
2 C $Name: $
3
4 C ECCO_CPPOPTIONS used to affect maxcvars and defined ALLOW_OBCS?_CONTROL
5 C#include "ECCO_CPPOPTIONS.h"
6 C now:
7 C CTRL_OPTIONS affects maxcvars and may define ALLOW_OBCS?_CONTROL
8 #include "CTRL_OPTIONS.h"
9
10 subroutine optim_writedata(
11 I nn,
12 I dfile,
13 I printlists,
14 I ff,
15 I vv
16 & )
17
18 c ==================================================================
19 c SUBROUTINE optim_writedata
20 c ==================================================================
21 c
22 c o Writes the latest update of the control vector to file(s). These
23 c files can then be used by the MITgcmUV state estimation setup
24 c for the next forward/adjoint simluation.
25 c
26 c started: Christian Eckert eckert@mit.edu 12-Apr-2000
27 c
28 c changed: Patrick Heimbach heimbach@mit.edu 19-Jun-2000
29 c - finished, revised and debugged
30 c
31 c ==================================================================
32 c SUBROUTINE optim_writedata
33 c ==================================================================
34
35 implicit none
36
37 c == global variables ==
38
39 #include "EEPARAMS.h"
40 #include "SIZE.h"
41 #if (defined (ALLOW_GENARR2D_CONTROL) || defined (ALLOW_GENARR3D_CONTROL) || defined (ALLOW_GENTIM2D_CONTROL))
42 #include "CTRL_SIZE.h"
43 #endif
44 # include "ctrl.h"
45 #include "optim.h"
46
47 c == routine arguments ==
48
49 integer nn
50 _RL ff
51 _RL vv(nn)
52
53 character*(9) dfile
54 logical printlists
55
56 c == local variables ==
57
58 integer i,j,k
59 integer ii
60 integer bi,bj
61 integer biG,bjG
62 integer nopt
63 integer icvcomp
64 integer icvoffset
65 integer icvrec
66 integer icvar
67 integer funit
68 integer cbuffindex
69
70 real*4 cbuff( sNx*nSx*nPx*sNy*nSy*nPy )
71
72 character*(128) fname
73 character*(18) prefix
74 parameter ( prefix = " OPTIM_WRITEDATA: " )
75 cgg(
76 _RL gg
77 integer igg
78 integer iobcs
79 cgg)
80
81 c == end of interface ==
82
83 c-- I/O unit to use.
84 funit = 20
85
86 c-- Next optimization cycle.
87 nopt = optimcycle + 1
88
89 if ( dfile .eq. ctrlname ) then
90 print*
91 print*,' OPTIM_WRITEDATA: Writing new control vector to file(s)'
92 print*,' for optimization cycle: ',nopt
93 print*
94 else
95 print*
96 print*,' OPTIM_WRITEDATA: subroutine called by a false *dfile*'
97 print*,' argument. *dfile* = ',dfile
98 print*
99 stop ' ... stopped in OPTIM_WRITEDATA.'
100 endif
101
102 bjG = 1 + (myygloballo - 1)/sny
103 biG = 1 + (myxgloballo - 1)/snx
104
105 c-- Generate file name and open the file.
106 write(fname(1:128),'(4a,i4.4)')
107 & dfile,'_',yctrlid(1:10),'.opt', nopt
108 open( funit, file = fname,
109 & status = 'new',
110 & form = 'unformatted',
111 & access = 'sequential' )
112
113 print *, prefix, 'nvartype ', nvartype
114 print *, prefix, 'nvarlength ', nvarlength
115 print *, prefix, 'yctrlid ', yctrlid
116 print *, prefix, 'nopt ', nopt
117 print *, prefix, 'ff ', ff
118 print *, prefix, 'iG ', biG
119 print *, prefix, 'jG ', bjG
120 print *, prefix, 'nsx ', nsx
121 print *, prefix, 'nsy ', nsy
122
123 if ( printlists ) then
124 print *, prefix, 'nWetcGlobal ', (nWetcGlobal(k), k=1,nr)
125 print *, prefix, 'nWetsGlobal ', (nWetsGlobal(k), k=1,nr)
126 print *, prefix, 'nWetwGlobal ', (nWetwGlobal(k), k=1,nr)
127 print *, prefix, 'nWetvGlobal ', (nWetvGlobal(k), k=1,nr)
128 print *, prefix, 'ncvarindex ', (ncvarindex(i), i=1,maxcvars)
129 print *, prefix, 'ncvarrecs ', (ncvarrecs(i), i=1,maxcvars)
130 print *, prefix, 'ncvarxmax ', (ncvarxmax(i), i=1,maxcvars)
131 print *, prefix, 'ncvarymax ', (ncvarymax(i), i=1,maxcvars)
132 print *, prefix, 'ncvarnrmax ', (ncvarnrmax(i), i=1,maxcvars)
133 print *, prefix, 'ncvargrd ', (ncvargrd(i), i=1,maxcvars)
134 endif
135
136
137 c-- Write the header.
138 write( funit ) nvartype
139 write( funit ) nvarlength
140 write( funit ) yctrlid
141 write( funit ) optimcycle
142 write( funit ) ff
143 write( funit ) big
144 write( funit ) bjg
145 write( funit ) nsx
146 write( funit ) nsy
147 write( funit ) (nWetcGlobal(k), k=1,nr)
148 write( funit ) (nWetsGlobal(k), k=1,nr)
149 write( funit ) (nWetwGlobal(k), k=1,nr)
150 #ifdef ALLOW_CTRL_WETV
151 write( funit ) (nWetvGlobal(k), k=1,nr)
152 #endif
153 #ifdef ALLOW_SHIFWFLX_CONTROL
154 write(funit) (nWetiGlobal(k), k=1,nr)
155 c write(funit) nWetiGlobal(1)
156 #endif
157
158 c Add OBCS Mask information into the header section for optimization.
159 #ifdef ALLOW_OBCSN_CONTROL
160 write(funit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
161 #endif
162 #ifdef ALLOW_OBCSS_CONTROL
163 write(funit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
164 #endif
165 #ifdef ALLOW_OBCSW_CONTROL
166 write(funit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
167 #endif
168 #ifdef ALLOW_OBCSE_CONTROL
169 write(funit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
170 #endif
171
172 write( funit ) (ncvarindex(i), i=1,maxcvars)
173 write( funit ) (ncvarrecs(i), i=1,maxcvars)
174 write( funit ) (ncvarxmax(i), i=1,maxcvars)
175 write( funit ) (ncvarymax(i), i=1,maxcvars)
176 write( funit ) (ncvarnrmax(i), i=1,maxcvars)
177 write( funit ) (ncvargrd(i), i=1,maxcvars)
178 write( funit )
179
180 c-- Write the data.
181 icvoffset = 0
182 do icvar = 1,maxcvars
183 if ( ncvarindex(icvar) .ne. -1 ) then
184 do icvrec = 1,ncvarrecs(icvar)
185 cph do bj = 1,nsy
186 cph do bi = 1,nsx
187 write( funit ) ncvarindex(icvar)
188 write( funit ) bj
189 write( funit ) bi
190 do k = 1,ncvarnrmax(icvar)
191 cbuffindex = 0
192 if (ncvargrd(icvar) .eq. 'c') then
193 cbuffindex = nWetcGlobal(k)
194 else if (ncvargrd(icvar) .eq. 's') then
195 cbuffindex = nWetsGlobal(k)
196 else if (ncvargrd(icvar) .eq. 'w') then
197 cbuffindex = nWetwGlobal(k)
198 else if (ncvargrd(icvar) .eq. 'v') then
199 cbuffindex = nWetvGlobal(k)
200 #ifdef ALLOW_SHIFWFLX_CONTROL
201 else if (ncvargrd(icvar) .eq. 'i') then
202 cbuffindex = nWetiGlobal(k)
203 #endif
204 c O.B. points have the grid mask "m".
205 else if (ncvargrd(icvar) .eq. 'm') then
206 c From "icvrec", calculate what iobcs must be.
207 gg = (icvrec-1)/nobcs
208 igg = int(gg)
209 iobcs= icvrec - igg*nobcs
210 #ifdef ALLOW_OBCSN_CONTROL
211 if (icvar .eq. 11) cbuffindex = nWetobcsnGlo(k,iobcs)
212 #endif
213 #ifdef ALLOW_OBCSS_CONTROL
214 if (icvar .eq. 12) cbuffindex = nWetobcssGlo(k,iobcs)
215 #endif
216 #ifdef ALLOW_OBCSW_CONTROL
217 if (icvar .eq. 13) cbuffindex = nWetobcswGlo(k,iobcs)
218 #endif
219 #ifdef ALLOW_OBCSE_CONTROL
220 if (icvar .eq. 14) cbuffindex = nWetobcseGlo(k,iobcs)
221 #endif
222 endif
223 if (cbuffindex .gt. 0) then
224 do icvcomp = 1,cbuffindex
225 cbuff(icvcomp) = vv(icvoffset + icvcomp)
226 c If you want to optimize with respect to just O.B. T and S
227 c uncomment the next two lines.
228 c if (iobcs .eq. 3) cbuff(icvcomp)=0.
229 c if (iobcs .eq. 4) cbuff(icvcomp)=0.
230 enddo
231 write( funit ) cbuffindex
232 write( funit ) k
233 write( funit ) (cbuff(ii), ii=1,cbuffindex)
234 icvoffset = icvoffset + cbuffindex
235 endif
236 enddo
237 cph enddo
238 cph enddo
239 enddo
240 endif
241 enddo
242
243 close( funit )
244
245 print *, prefix, 'end of optim_writedata, icvoffset ', icvoffset
246 print *, ' '
247
248 return
249 end
250
251
252
253

  ViewVC Help
Powered by ViewVC 1.1.22