1 |
C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_map_ini_genarr.F,v 1.27 2017/04/05 23:02:53 ou.wang Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "CTRL_OPTIONS.h" |
5 |
#ifdef ALLOW_GMREDI |
6 |
# include "GMREDI_OPTIONS.h" |
7 |
#endif |
8 |
|
9 |
CBOP |
10 |
C !ROUTINE: CTRL_MAP_INI_GENARR |
11 |
C !INTERFACE: |
12 |
SUBROUTINE CTRL_MAP_INI_GENARR( myThid ) |
13 |
|
14 |
C !DESCRIPTION: \bv |
15 |
C *================================================================= |
16 |
C | SUBROUTINE CTRL_MAP_INI_GENARR |
17 |
C | Add the generic arrays of the |
18 |
C | control vector to the model state and update the tile halos. |
19 |
C | The control vector is defined in the header file "ctrl.h". |
20 |
C *================================================================= |
21 |
C \ev |
22 |
|
23 |
C !USES: |
24 |
IMPLICIT NONE |
25 |
|
26 |
C == global variables == |
27 |
#include "SIZE.h" |
28 |
#include "EEPARAMS.h" |
29 |
#include "PARAMS.h" |
30 |
#include "GRID.h" |
31 |
#include "DYNVARS.h" |
32 |
#include "FFIELDS.h" |
33 |
#include "CTRL_SIZE.h" |
34 |
#include "ctrl.h" |
35 |
#include "optim.h" |
36 |
#include "ctrl_dummy.h" |
37 |
#include "CTRL_FIELDS.h" |
38 |
#include "CTRL_GENARR.h" |
39 |
#ifdef ALLOW_PTRACERS |
40 |
# include "PTRACERS_SIZE.h" |
41 |
# include "PTRACERS_FIELDS.h" |
42 |
#endif |
43 |
|
44 |
C !INPUT/OUTPUT PARAMETERS: |
45 |
C == routine arguments == |
46 |
INTEGER myThid |
47 |
|
48 |
C !LOCAL VARIABLES: |
49 |
C == local variables == |
50 |
#if (defined (ALLOW_GENARR2D_CONTROL) || defined(ALLOW_GENARR3D_CONTROL)) |
51 |
integer iarr |
52 |
#endif |
53 |
#ifdef ALLOW_GENARR2D_CONTROL |
54 |
integer igen_etan,igen_bdrag,igen_geoth |
55 |
#endif /* ALLOW_GENARR2D_CONTROL */ |
56 |
#ifdef ALLOW_GENARR3D_CONTROL |
57 |
integer igen_theta0, igen_salt0 |
58 |
integer igen_kapgm, igen_kapredi, igen_diffkr |
59 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
60 |
integer igen_uvel0, igen_vvel0 |
61 |
#endif |
62 |
#endif /* ALLOW_GENARR3D_CONTROL */ |
63 |
CEOP |
64 |
|
65 |
#ifdef ALLOW_GENARR2D_CONTROL |
66 |
|
67 |
C-- generic 2D control variables |
68 |
|
69 |
igen_etan=0 |
70 |
igen_bdrag=0 |
71 |
igen_geoth=0 |
72 |
DO iarr = 1, maxCtrlArr2D |
73 |
if (xx_genarr2d_weight(iarr).NE.' ') then |
74 |
if (xx_genarr2d_file(iarr)(1:7).EQ.'xx_etan') |
75 |
& igen_etan=iarr |
76 |
if (xx_genarr2d_file(iarr)(1:13).EQ.'xx_bottomdrag') |
77 |
& igen_bdrag=iarr |
78 |
if (xx_genarr2d_file(iarr)(1:13).EQ.'xx_geothermal') |
79 |
& igen_geoth=iarr |
80 |
endif |
81 |
ENDDO |
82 |
|
83 |
if (igen_etan.GT.0) then |
84 |
call ctrl_map_genarr2d(etaN,igen_etan,myThid) |
85 |
endif |
86 |
#ifdef ALLOW_BOTTOMDRAG_CONTROL |
87 |
if (igen_bdrag.GT.0) |
88 |
& call ctrl_map_genarr2d(bottomDragFld,igen_bdrag,myThid) |
89 |
#endif |
90 |
#ifdef ALLOW_GEOTHERMAL_FLUX |
91 |
if (igen_geoth.GT.0) |
92 |
& call ctrl_map_genarr2d(geothermalFlux,igen_geoth,myThid) |
93 |
#endif |
94 |
|
95 |
#endif /* ALLOW_GENARR2D_CONTROL */ |
96 |
|
97 |
#ifdef ALLOW_GENARR3D_CONTROL |
98 |
|
99 |
C-- generic 3D control variables |
100 |
|
101 |
igen_theta0=0 |
102 |
igen_salt0=0 |
103 |
igen_kapgm=0 |
104 |
igen_kapredi=0 |
105 |
igen_diffkr=0 |
106 |
DO iarr = 1, maxCtrlArr3D |
107 |
if (xx_genarr3d_weight(iarr).NE.' ') then |
108 |
if (xx_genarr3d_file(iarr)(1:8).EQ.'xx_theta') |
109 |
& igen_theta0=iarr |
110 |
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_salt') |
111 |
& igen_salt0=iarr |
112 |
if (xx_genarr3d_file(iarr)(1:8).EQ.'xx_kapgm') |
113 |
& igen_kapgm=iarr |
114 |
if (xx_genarr3d_file(iarr)(1:10).EQ.'xx_kapredi') |
115 |
& igen_kapredi=iarr |
116 |
if (xx_genarr3d_file(iarr)(1:9).EQ.'xx_diffkr') |
117 |
& igen_diffkr=iarr |
118 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
119 |
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_uvel') |
120 |
& igen_uvel0=iarr |
121 |
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_vvel') |
122 |
& igen_vvel0=iarr |
123 |
#endif |
124 |
endif |
125 |
ENDDO |
126 |
|
127 |
if (igen_theta0.GT.0) |
128 |
& call ctrl_map_genarr3d(theta,igen_theta0,myThid) |
129 |
if (igen_salt0.GT.0) |
130 |
& call ctrl_map_genarr3d(salt,igen_salt0,myThid) |
131 |
#ifdef ALLOW_KAPGM_CONTROL |
132 |
if (igen_kapgm.GT.0) |
133 |
& call ctrl_map_genarr3d(kapgm,igen_kapgm,myThid) |
134 |
#endif |
135 |
#ifdef ALLOW_KAPREDI_CONTROL |
136 |
if (igen_kapredi.GT.0) |
137 |
& call ctrl_map_genarr3d(kapredi,igen_kapredi,myThid) |
138 |
#endif |
139 |
#ifdef ALLOW_3D_DIFFKR |
140 |
if (igen_diffkr.GT.0) |
141 |
& call ctrl_map_genarr3d(diffkr,igen_diffkr,myThid) |
142 |
#endif |
143 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
144 |
if (igen_uvel0.GT.0 .and. igen_vvel0.GT.0) then |
145 |
call ctrl_map_genarr3d(uvel,igen_uvel0,myThid) |
146 |
call ctrl_map_genarr3d(vvel,igen_vvel0,myThid) |
147 |
CALL EXCH_UV_XYZ_RL(uvel,vvel,.TRUE.,myThid) |
148 |
endif |
149 |
#endif |
150 |
|
151 |
#endif /* ALLOW_GENARR3D_CONTROL */ |
152 |
|
153 |
RETURN |
154 |
END |
155 |
|
156 |
C--------------------------- |
157 |
|
158 |
C !ROUTINE: CTRL_MAP_GENARR2D |
159 |
C !INTERFACE: |
160 |
SUBROUTINE CTRL_MAP_GENARR2D( fld, iarr, myThid ) |
161 |
|
162 |
C !DESCRIPTION: \bv |
163 |
C *================================================================= |
164 |
C | SUBROUTINE CTRL_MAP_GENARR2D |
165 |
C | Add the generic arrays of the |
166 |
C | control vector to the model state and update the tile halos. |
167 |
C | The control vector is defined in the header file "ctrl.h". |
168 |
C *================================================================= |
169 |
C \ev |
170 |
|
171 |
C !USES: |
172 |
IMPLICIT NONE |
173 |
|
174 |
C == global variables == |
175 |
#include "SIZE.h" |
176 |
#include "EEPARAMS.h" |
177 |
#include "PARAMS.h" |
178 |
#include "GRID.h" |
179 |
|
180 |
#include "CTRL_SIZE.h" |
181 |
#include "ctrl.h" |
182 |
#include "optim.h" |
183 |
#include "CTRL_GENARR.h" |
184 |
#include "ctrl_dummy.h" |
185 |
|
186 |
C !INPUT/OUTPUT PARAMETERS: |
187 |
C == routine arguments == |
188 |
_RL fld (1-olx:snx+olx,1-oly:sny+oly,nsx,nsy) |
189 |
INTEGER iarr |
190 |
INTEGER myThid |
191 |
|
192 |
#ifdef ALLOW_GENARR2D_CONTROL |
193 |
|
194 |
C !LOCAL VARIABLES: |
195 |
C == local variables == |
196 |
integer bi,bj |
197 |
integer i,j |
198 |
integer jmin,jmax |
199 |
integer imin,imax |
200 |
integer numsmo, k2 |
201 |
logical dowc01 |
202 |
logical dosmooth |
203 |
logical doscaling |
204 |
_RL xx_gen (1-olx:snx+olx,1-oly:sny+oly,nsx,nsy) |
205 |
_RS dummyRS(1) |
206 |
character*(80) fnamegenIn |
207 |
character*(80) fnamegenOut |
208 |
character*(80) fnamebase |
209 |
INTEGER ILNBLNK |
210 |
EXTERNAL ILNBLNK |
211 |
integer ilgen |
212 |
logical doglobalread |
213 |
logical ladinit |
214 |
CEOP |
215 |
|
216 |
c-- Now, read the control vector. |
217 |
doglobalread = .false. |
218 |
ladinit = .false. |
219 |
|
220 |
DO bj=myByLo(myThid), myByHi(myThid) |
221 |
DO bi=myBxLo(myThid), myBxHi(myThid) |
222 |
DO j = 1-OLy,sNy+OLy |
223 |
DO i = 1-OLx,sNx+OLx |
224 |
xx_gen(i,j,bi,bj)=0. _d 0 |
225 |
ENDDO |
226 |
ENDDO |
227 |
ENDDO |
228 |
ENDDO |
229 |
|
230 |
dosmooth=.false. |
231 |
dowc01 = .false. |
232 |
doscaling=.true. |
233 |
|
234 |
numsmo=1 |
235 |
do k2 = 1, maxCtrlProc |
236 |
if (xx_genarr2d_preproc(k2,iarr).EQ.'WC01') then |
237 |
dowc01=.TRUE. |
238 |
if (xx_genarr2d_preproc_i(k2,iarr).NE.0) |
239 |
& numsmo=xx_genarr2d_preproc_i(k2,iarr) |
240 |
endif |
241 |
if ((.NOT.dowc01).AND. |
242 |
& (xx_genarr2d_preproc(k2,iarr).EQ.'smooth')) then |
243 |
dosmooth=.TRUE. |
244 |
if (xx_genarr2d_preproc_i(k2,iarr).NE.0) |
245 |
& numsmo=xx_genarr2d_preproc_i(k2,iarr) |
246 |
endif |
247 |
if (xx_genarr2d_preproc(k2,iarr).EQ.'noscaling') then |
248 |
doscaling=.FALSE. |
249 |
endif |
250 |
enddo |
251 |
|
252 |
fnamebase = xx_genarr2d_file(iarr) |
253 |
ilgen=ilnblnk( fnamebase ) |
254 |
write(fnamegenIn(1:80),'(2a,i10.10)') |
255 |
& fnamebase(1:ilgen),'.',optimcycle |
256 |
write(fnamegenOut(1:80),'(2a,i10.10)') |
257 |
& fnamebase(1:ilgen),'.effective.',optimcycle |
258 |
|
259 |
CALL MDS_READ_FIELD(xx_genarr2d_weight(iarr),ctrlprec,.FALSE., |
260 |
& 'RL',1,1,1,wgenarr2d(1-Olx,1-Oly,1,1,iarr),dummyRS,1,mythid) |
261 |
|
262 |
#ifdef ALLOW_AUTODIFF |
263 |
call active_read_xy( fnamegenIn, xx_gen, 1, doglobalread, |
264 |
& ladinit, optimcycle, mythid, xx_genarr2d_dummy(iarr) ) |
265 |
#else |
266 |
CALL READ_REC_XY_RL( fnamegenIn, xx_gen, 1, 1, myThid) |
267 |
#endif |
268 |
|
269 |
#ifdef ALLOW_SMOOTH |
270 |
IF (useSMOOTH) THEN |
271 |
IF (dowc01) call smooth_correl2d(xx_gen,maskC,numsmo,mythid) |
272 |
IF (dosmooth) call smooth2d(xx_gen,maskC,numsmo,mythid) |
273 |
ENDIF |
274 |
#endif |
275 |
|
276 |
DO bj=myByLo(myThid), myByHi(myThid) |
277 |
DO bi=myBxLo(myThid), myBxHi(myThid) |
278 |
DO j = 1,sNy |
279 |
DO i = 1,sNx |
280 |
c scale param adjustment |
281 |
IF (doscaling) then |
282 |
if ( (maskC(i,j,1,bi,bj).NE.0.).AND. |
283 |
& (wgenarr2d(i,j,bi,bj,iarr).GT.0.) ) then |
284 |
xx_gen(i,j,bi,bj)=xx_gen(i,j,bi,bj) |
285 |
& /sqrt( wgenarr2d(i,j,bi,bj,iarr) ) |
286 |
else |
287 |
xx_gen(i,j,bi,bj)=0. |
288 |
endif |
289 |
ENDIF |
290 |
c add to model parameter |
291 |
fld(i,j,bi,bj)=fld(i,j,bi,bj)+xx_gen(i,j,bi,bj) |
292 |
enddo |
293 |
enddo |
294 |
enddo |
295 |
enddo |
296 |
|
297 |
c avoid param out of [boundsVec(1) boundsVec(4)] |
298 |
CALL CTRL_BOUND_2D(fld,maskC,xx_genarr2d_bounds(1,iarr),myThid) |
299 |
|
300 |
CALL EXCH_XY_RL( fld, mythid ) |
301 |
|
302 |
CALL MDS_WRITE_FIELD(fnamegenOut,ctrlprec,.FALSE.,.FALSE., |
303 |
& 'RL',1,1,1,fld,dummyRS,1,optimcycle,mythid) |
304 |
|
305 |
|
306 |
#endif /* ALLOW_GENARR2D_CONTROL */ |
307 |
|
308 |
RETURN |
309 |
END |
310 |
|
311 |
C--------------------------- |
312 |
|
313 |
C !ROUTINE: CTRL_MAP_GENARR3D |
314 |
C !INTERFACE: |
315 |
SUBROUTINE CTRL_MAP_GENARR3D( fld, iarr, myThid ) |
316 |
|
317 |
C !DESCRIPTION: \bv |
318 |
C *================================================================= |
319 |
C | SUBROUTINE CTRL_MAP_GENARR3D |
320 |
C | Add the generic arrays of the |
321 |
C | control vector to the model state and update the tile halos. |
322 |
C | The control vector is defined in the header file "ctrl.h". |
323 |
C *================================================================= |
324 |
C \ev |
325 |
|
326 |
C !USES: |
327 |
IMPLICIT NONE |
328 |
|
329 |
C == global variables == |
330 |
#include "SIZE.h" |
331 |
#include "EEPARAMS.h" |
332 |
#include "PARAMS.h" |
333 |
#include "GRID.h" |
334 |
|
335 |
#include "CTRL_SIZE.h" |
336 |
#include "ctrl.h" |
337 |
#include "optim.h" |
338 |
#include "CTRL_GENARR.h" |
339 |
#include "ctrl_dummy.h" |
340 |
|
341 |
C !INPUT/OUTPUT PARAMETERS: |
342 |
C == routine arguments == |
343 |
_RL fld (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy) |
344 |
INTEGER iarr |
345 |
INTEGER myThid |
346 |
|
347 |
#ifdef ALLOW_GENARR3D_CONTROL |
348 |
|
349 |
C !LOCAL VARIABLES: |
350 |
C == local variables == |
351 |
integer bi,bj |
352 |
integer i,j,k |
353 |
integer numsmo,k2 |
354 |
logical dowc01 |
355 |
logical dosmooth |
356 |
logical doscaling |
357 |
_RL xx_gen (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy) |
358 |
_RS dummyRS(1) |
359 |
character*(80) fnamegenIn |
360 |
character*(80) fnamegenOut |
361 |
character*(80) fnamebase |
362 |
INTEGER ILNBLNK |
363 |
EXTERNAL ILNBLNK |
364 |
integer ilgen |
365 |
logical doglobalread |
366 |
logical ladinit |
367 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
368 |
_RL localmask (1-olx:snx+olx,1-oly:sny+oly,nr,nsx,nsy) |
369 |
#endif |
370 |
CEOP |
371 |
|
372 |
c-- Now, read the control vector. |
373 |
doglobalread = .false. |
374 |
ladinit = .false. |
375 |
|
376 |
DO bj=myByLo(myThid), myByHi(myThid) |
377 |
DO bi=myBxLo(myThid), myBxHi(myThid) |
378 |
DO k = 1,nr |
379 |
DO j = 1-OLy,sNy+OLy |
380 |
DO i = 1-OLx,sNx+OLx |
381 |
xx_gen(i,j,k,bi,bj)=0. _d 0 |
382 |
ENDDO |
383 |
ENDDO |
384 |
ENDDO |
385 |
ENDDO |
386 |
ENDDO |
387 |
|
388 |
dosmooth=.false. |
389 |
dowc01 = .false. |
390 |
doscaling=.true. |
391 |
|
392 |
numsmo=1 |
393 |
do k2 = 1, maxCtrlProc |
394 |
if (xx_genarr3d_preproc(k2,iarr).EQ.'WC01') then |
395 |
dowc01=.TRUE. |
396 |
if (xx_genarr3d_preproc_i(k2,iarr).NE.0) |
397 |
& numsmo=xx_genarr3d_preproc_i(k2,iarr) |
398 |
endif |
399 |
if ((.NOT.dowc01).AND. |
400 |
& (xx_genarr3d_preproc(k2,iarr).EQ.'smooth')) then |
401 |
dosmooth=.TRUE. |
402 |
if (xx_genarr3d_preproc_i(k2,iarr).NE.0) |
403 |
& numsmo=xx_genarr3d_preproc_i(k2,iarr) |
404 |
endif |
405 |
if (xx_genarr3d_preproc(k2,iarr).EQ.'noscaling') then |
406 |
doscaling=.FALSE. |
407 |
endif |
408 |
enddo |
409 |
|
410 |
fnamebase = xx_genarr3d_file(iarr) |
411 |
ilgen=ilnblnk( fnamebase ) |
412 |
write(fnamegenIn(1:80),'(2a,i10.10)') |
413 |
& fnamebase(1:ilgen),'.',optimcycle |
414 |
write(fnamegenOut(1:80),'(2a,i10.10)') |
415 |
& fnamebase(1:ilgen),'.effective.',optimcycle |
416 |
|
417 |
CALL MDS_READ_FIELD(xx_genarr3d_weight(iarr),ctrlprec,.FALSE., |
418 |
& 'RL',nR,1,nR,wgenarr3d(1-Olx,1-Oly,1,1,1,iarr),dummyRS,1,mythid) |
419 |
|
420 |
#ifdef ALLOW_AUTODIFF |
421 |
call active_read_xyz( fnamegenIn, xx_gen, 1, doglobalread, |
422 |
& ladinit, optimcycle, mythid, xx_genarr3d_dummy(iarr) ) |
423 |
#else |
424 |
CALL READ_REC_XYZ_RL( fnamegenIn, xx_gen, 1, 1, myThid) |
425 |
#endif |
426 |
|
427 |
#ifdef ALLOW_SMOOTH |
428 |
IF (useSMOOTH) THEN |
429 |
IF (dowc01) call smooth_correl3d(xx_gen,numsmo,mythid) |
430 |
IF (dosmooth) call smooth3d(xx_gen,numsmo,mythid) |
431 |
ENDIF |
432 |
#endif |
433 |
|
434 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
435 |
c-- set local mask |
436 |
call ecco_zero(localmask,Nr,zeroRL,myThid) |
437 |
if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_uvel') then |
438 |
call ecco_cprsrl(maskW,nr,localmask,nr,myThid) |
439 |
else if (xx_genarr3d_file(iarr)(1:7).EQ.'xx_vvel') then |
440 |
call ecco_cprsrl(maskS,nr,localmask,nr,myThid) |
441 |
else |
442 |
call ecco_cprsrl(maskC,nr,localmask,nr,myThid) |
443 |
endif |
444 |
#endif |
445 |
|
446 |
DO bj=myByLo(myThid), myByHi(myThid) |
447 |
DO bi=myBxLo(myThid), myBxHi(myThid) |
448 |
do k = 1,nr |
449 |
DO j = 1,sNy |
450 |
DO i = 1,sNx |
451 |
c scale param adjustment |
452 |
IF (doscaling) then |
453 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
454 |
if ( (localmask(i,j,k,bi,bj).NE.0.).AND. |
455 |
#else |
456 |
if ( (maskC(i,j,k,bi,bj).NE.0.).AND. |
457 |
#endif |
458 |
& (wgenarr3d(i,j,k,bi,bj,iarr).GT.0.) ) then |
459 |
xx_gen(i,j,k,bi,bj)=xx_gen(i,j,k,bi,bj) |
460 |
& /sqrt( wgenarr3d(i,j,k,bi,bj,iarr) ) |
461 |
else |
462 |
xx_gen(i,j,k,bi,bj)=0. |
463 |
endif |
464 |
ENDIF |
465 |
c add to model parameter |
466 |
fld(i,j,k,bi,bj)=fld(i,j,k,bi,bj)+xx_gen(i,j,k,bi,bj) |
467 |
enddo |
468 |
enddo |
469 |
enddo |
470 |
enddo |
471 |
enddo |
472 |
|
473 |
c avoid param out of [boundsVec(1) boundsVec(4)] |
474 |
#if (defined (ALLOW_UVEL0_CONTROL) && defined (ALLOW_VVEL0_CONTROL)) |
475 |
CALL CTRL_BOUND_3D(fld,localmask, |
476 |
& xx_genarr3d_bounds(1,iarr),myThid) |
477 |
#else |
478 |
CALL CTRL_BOUND_3D(fld,maskC,xx_genarr3d_bounds(1,iarr),myThid) |
479 |
#endif |
480 |
|
481 |
C The tile exchange for xx_uvel and xx_vvel will be |
482 |
C done in CTRL_MAP_INI_GENARR.F when both |
483 |
C xx_uvel and xx_vvel are read in. |
484 |
if (xx_genarr3d_file(iarr)(1:7).NE.'xx_uvel'.AND. |
485 |
& xx_genarr3d_file(iarr)(1:7).NE.'xx_vvel') |
486 |
& CALL EXCH_XYZ_RL( fld, mythid ) |
487 |
|
488 |
CALL MDS_WRITE_FIELD(fnamegenOut,ctrlprec,.FALSE.,.FALSE., |
489 |
& 'RL',nr,1,nr,fld,dummyRS,1,optimcycle,mythid) |
490 |
|
491 |
#endif /* ALLOW_GENARR3D_CONTROL */ |
492 |
|
493 |
RETURN |
494 |
END |
495 |
|
496 |
|