da_generic_boilerplate.inc
References to this file elsewhere.
1 !
2 ! WRFVAR generic type macro file
3 !
4 ! This file is used to generate a series of simple boiler-plate calls
5 ! to support residual generic types for bitwise-exact testing.
6 ! It contains M4 macros and then
7 ! a series of invocations of the macros to generate the subroutine
8 ! definitions, which are then included in another source file.
9 !
10
11 ! $1 = specific ob namme, $2 = specific ob type, $3 = ob counter
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31 !--- sound sound num_sound
32
33 SUBROUTINE da_y_type_ex_sound( iv, re, slice )
34
35 !------------------------------------------------------------------------------
36 ! PURPOSE: Eliminate redundant code for many obs types.
37 !
38 ! METHOD: Extract all sound obs from y and place them in generic
39 ! object slice.
40 ! Call da_y_facade_free() to deallocate memory allocated here.
41 !------------------------------------------------------------------------------
42 IMPLICIT NONE
43
44 type (ob_type), INTENT(IN ) :: iv ! Innovation vector
45 type (y_type), INTENT(IN ) :: re ! all residual obs
46 type (y_facade_type), INTENT(INOUT) :: slice ! selected residual obs
47 ! Local declarations
48 INTEGER :: n
49
50 CALL da_y_facade_create( slice, iv%num_sound, iv%num_sound_glo )
51 DO n=1, slice%num_obs
52 CALL da_res_generic_set_info( slice%obs(n), &
53 iv%sound(n)%loc%proc_domain, &
54 iv%sound(n)%loc%obs_global_index )
55 CALL da_res_sound_to_generic( re%sound(n), iv%sound(n)%info%levels, &
56 slice%obs(n) )
57 ENDDO
58
59 END SUBROUTINE da_y_type_ex_sound
60
61
62 !--- sound sound num_sound
63
64 SUBROUTINE da_y_type_ins_sound_global( slice_glob, re_glob )
65
66 !------------------------------------------------------------------------------
67 ! PURPOSE: Eliminate redundant code for many obs types.
68 !
69 ! METHOD: Insert obs from generic object slice_glob into
70 ! globally-scoped y_type re_glob. re_glob is
71 ! allocated minimally. Caller must deallocate.
72 ! Memory for global object slice_glob is deallocated here.
73 ! Do not use slice_glob after this call.
74 !------------------------------------------------------------------------------
75 IMPLICIT NONE
76
77 type (y_facade_type), INTENT(INOUT) :: slice_glob ! generic
78 type (y_type), INTENT(INOUT) :: re_glob ! selected residual obs
79 ! Local declarations
80 INTEGER :: n
81
82 ! allocate and initialize obs
83 ! deallocation is done in free_global_sound()
84 ALLOCATE( re_glob%sound(slice_glob%num_obs) )
85 DO n=1, slice_glob%num_obs
86 CALL da_res_sound_from_generic( slice_glob%obs(n), re_glob%sound(n) )
87 ENDDO
88 re_glob%num_sound = slice_glob%num_obs ! duplication!
89 CALL da_y_facade_free( slice_glob )
90
91 END SUBROUTINE da_y_type_ins_sound_global
92
93
94 !--- sound sound num_sound
95
96 SUBROUTINE da_iv_type_ins_sound_global( slice_glob, iv_glob )
97
98 !------------------------------------------------------------------------------
99 ! PURPOSE: Eliminate redundant code for many obs types.
100 !
101 ! METHOD: Insert meta-data from generic object slice_glob into
102 ! globally-scoped ob_type iv_glob. iv_glob is
103 ! allocated minimally. Caller must deallocate.
104 !------------------------------------------------------------------------------
105 IMPLICIT NONE
106
107 type (y_facade_type), INTENT(IN ) :: slice_glob ! selected residual obs
108 type (ob_type), INTENT(INOUT) :: iv_glob ! partial Innovation vector
109 ! Local declarations
110 INTEGER :: n
111
112 ! allocate and initialize needed bits of iv_glob (ugly)
113 iv_glob%num_sound = slice_glob%num_obs
114 iv_glob%num_sound_glo = slice_glob%num_obs_glo
115 ! deallocation is done in free_global_sound()
116 ALLOCATE( iv_glob%sound(iv_glob%num_sound) )
117 DO n=1, iv_glob%num_sound
118 iv_glob%sound(n)%loc%proc_domain = slice_glob%obs(n)%proc_domain
119 iv_glob%sound(n)%loc%obs_global_index = &
120 slice_glob%obs(n)%obs_global_index
121 IF ( da_res_generic_has_vector( slice_glob%obs(n) ) ) THEN
122 iv_glob%sound(n)%info%levels = SIZE(slice_glob%obs(n)%values(1)%ptr)
123 ENDIF
124 ENDDO
125
126 END SUBROUTINE da_iv_type_ins_sound_global
127
128
129 !--- sound sound num_sound
130
131 !------------------------------------------------------------------------------
132 ! PURPOSE: Collect local arrays of residual_sound_type objects into
133 ! global arrays in serial-code storage order. This is used to
134 ! perform bitwise-exact floating-point summations in
135 ! serial-code-order during bitwise-exact testing of
136 ! distributed-memory parallel configurations.
137 !
138 ! METHOD: Indices stowed away during Read_Obs() are used to restore serial
139 ! storage order. Memory for global objects is allocated here.
140 ! Global objects are minimally allocated to save memory.
141 ! Memory is deallocated in free_global_sound().
142 !------------------------------------------------------------------------------
143 SUBROUTINE da_to_global_sound( iv, re, jo_grad_y, &
144 iv_glob, re_glob, jo_grad_y_glob )
145
146 IMPLICIT NONE
147
148 ! task-local objects
149 type (ob_type), INTENT( IN) :: iv ! Innovation vector
150 type (y_type), INTENT( IN) :: re ! residual vector
151 type (y_type), INTENT( IN) :: jo_grad_y ! Grad_y(Jo)
152 ! task-global objects
153 type (ob_type), INTENT(OUT) :: iv_glob ! Innovation vector
154 type (y_type), INTENT(OUT) :: re_glob ! residual vector
155 type (y_type), INTENT(OUT) :: jo_grad_y_glob ! Grad_y(Jo)
156
157 ! Local declarations
158 type (y_facade_type) :: re_slice, re_glob_slice
159 type (y_facade_type) :: jo_grad_y_slice, jo_grad_y_glob_slice
160 type (residual_template_type) :: template ! allocation info
161
162 ! create process-local generic objects from specific objects
163 CALL da_y_type_ex_sound( iv, re, re_slice )
164 CALL da_y_type_ex_sound( iv, jo_grad_y, jo_grad_y_slice )
165
166 ! create global versions of generic objects from process-local objects
167 ! and destroy process-local generic objects
168 CALL da_res_sound_create_template( template ) ! use template in case
169 ! some tasks have no obs
170 CALL da_y_facade_to_global( re_slice, template, re_glob_slice )
171 CALL da_y_facade_to_global( jo_grad_y_slice, template, jo_grad_y_glob_slice )
172
173 ! create global versions of specific objects
174 ! and destroy global versions of generic objects
175 ! iv first
176 CALL da_iv_type_ins_sound_global( re_glob_slice, iv_glob )
177 ! then y_types
178 CALL da_y_type_ins_sound_global( re_glob_slice, re_glob )
179 CALL da_y_type_ins_sound_global( jo_grad_y_glob_slice, jo_grad_y_glob )
180 ! global versions of specific objects are destroyed in
181 ! free_global_sound()
182
183 RETURN
184
185 END SUBROUTINE da_to_global_sound
186
187
188 !--- sonde_sfc synop num_sound
189
190 SUBROUTINE da_y_type_ex_sonde_sfc( iv, re, slice )
191
192 !------------------------------------------------------------------------------
193 ! PURPOSE: Eliminate redundant code for many obs types.
194 !
195 ! METHOD: Extract all sonde_sfc obs from y and place them in generic
196 ! object slice.
197 ! Call da_y_facade_free() to deallocate memory allocated here.
198 !------------------------------------------------------------------------------
199 IMPLICIT NONE
200
201 type (ob_type), INTENT(IN ) :: iv ! Innovation vector
202 type (y_type), INTENT(IN ) :: re ! all residual obs
203 type (y_facade_type), INTENT(INOUT) :: slice ! selected residual obs
204 ! Local declarations
205 INTEGER :: n
206
207 CALL da_y_facade_create( slice, iv%num_sound, iv%num_sound_glo )
208 DO n=1, slice%num_obs
209 CALL da_res_generic_set_info( slice%obs(n), &
210 iv%sonde_sfc(n)%loc%proc_domain, &
211 iv%sonde_sfc(n)%loc%obs_global_index )
212 CALL da_res_synop_to_generic( re%sonde_sfc(n), iv%sonde_sfc(n)%info%levels, &
213 slice%obs(n) )
214 ENDDO
215
216 END SUBROUTINE da_y_type_ex_sonde_sfc
217
218
219 !--- sonde_sfc synop num_sound
220
221 SUBROUTINE da_y_type_ins_sonde_sfc_global( slice_glob, re_glob )
222
223 !------------------------------------------------------------------------------
224 ! PURPOSE: Eliminate redundant code for many obs types.
225 !
226 ! METHOD: Insert obs from generic object slice_glob into
227 ! globally-scoped y_type re_glob. re_glob is
228 ! allocated minimally. Caller must deallocate.
229 ! Memory for global object slice_glob is deallocated here.
230 ! Do not use slice_glob after this call.
231 !------------------------------------------------------------------------------
232 IMPLICIT NONE
233
234 type (y_facade_type), INTENT(INOUT) :: slice_glob ! generic
235 type (y_type), INTENT(INOUT) :: re_glob ! selected residual obs
236 ! Local declarations
237 INTEGER :: n
238
239 ! allocate and initialize obs
240 ! deallocation is done in free_global_sonde_sfc()
241 ALLOCATE( re_glob%sonde_sfc(slice_glob%num_obs) )
242 DO n=1, slice_glob%num_obs
243 CALL da_res_synop_from_generic( slice_glob%obs(n), re_glob%sonde_sfc(n) )
244 ENDDO
245 re_glob%num_sound = slice_glob%num_obs ! duplication!
246 CALL da_y_facade_free( slice_glob )
247
248 END SUBROUTINE da_y_type_ins_sonde_sfc_global
249
250
251 !--- sonde_sfc synop num_sound
252
253 SUBROUTINE da_iv_type_ins_sonde_sfc_global( slice_glob, iv_glob )
254
255 !------------------------------------------------------------------------------
256 ! PURPOSE: Eliminate redundant code for many obs types.
257 !
258 ! METHOD: Insert meta-data from generic object slice_glob into
259 ! globally-scoped ob_type iv_glob. iv_glob is
260 ! allocated minimally. Caller must deallocate.
261 !------------------------------------------------------------------------------
262 IMPLICIT NONE
263
264 type (y_facade_type), INTENT(IN ) :: slice_glob ! selected residual obs
265 type (ob_type), INTENT(INOUT) :: iv_glob ! partial Innovation vector
266 ! Local declarations
267 INTEGER :: n
268
269 ! allocate and initialize needed bits of iv_glob (ugly)
270 iv_glob%num_sound = slice_glob%num_obs
271 iv_glob%num_sound_glo = slice_glob%num_obs_glo
272 ! deallocation is done in free_global_sonde_sfc()
273 ALLOCATE( iv_glob%sonde_sfc(iv_glob%num_sound) )
274 DO n=1, iv_glob%num_sound
275 iv_glob%sonde_sfc(n)%loc%proc_domain = slice_glob%obs(n)%proc_domain
276 iv_glob%sonde_sfc(n)%loc%obs_global_index = &
277 slice_glob%obs(n)%obs_global_index
278 IF ( da_res_generic_has_vector( slice_glob%obs(n) ) ) THEN
279 iv_glob%sonde_sfc(n)%info%levels = SIZE(slice_glob%obs(n)%values(1)%ptr)
280 ENDIF
281 ENDDO
282
283 END SUBROUTINE da_iv_type_ins_sonde_sfc_global
284
285
286 !--- sonde_sfc synop num_sound
287
288 !------------------------------------------------------------------------------
289 ! PURPOSE: Collect local arrays of residual_synop_type objects into
290 ! global arrays in serial-code storage order. This is used to
291 ! perform bitwise-exact floating-point summations in
292 ! serial-code-order during bitwise-exact testing of
293 ! distributed-memory parallel configurations.
294 !
295 ! METHOD: Indices stowed away during Read_Obs() are used to restore serial
296 ! storage order. Memory for global objects is allocated here.
297 ! Global objects are minimally allocated to save memory.
298 ! Memory is deallocated in free_global_sonde_sfc().
299 !------------------------------------------------------------------------------
300 SUBROUTINE da_to_global_sonde_sfc( iv, re, jo_grad_y, &
301 iv_glob, re_glob, jo_grad_y_glob )
302
303 IMPLICIT NONE
304
305 ! task-local objects
306 type (ob_type), INTENT( IN) :: iv ! Innovation vector
307 type (y_type), INTENT( IN) :: re ! residual vector
308 type (y_type), INTENT( IN) :: jo_grad_y ! Grad_y(Jo)
309 ! task-global objects
310 type (ob_type), INTENT(OUT) :: iv_glob ! Innovation vector
311 type (y_type), INTENT(OUT) :: re_glob ! residual vector
312 type (y_type), INTENT(OUT) :: jo_grad_y_glob ! Grad_y(Jo)
313
314 ! Local declarations
315 type (y_facade_type) :: re_slice, re_glob_slice
316 type (y_facade_type) :: jo_grad_y_slice, jo_grad_y_glob_slice
317 type (residual_template_type) :: template ! allocation info
318
319 ! create process-local generic objects from specific objects
320 CALL da_y_type_ex_sonde_sfc( iv, re, re_slice )
321 CALL da_y_type_ex_sonde_sfc( iv, jo_grad_y, jo_grad_y_slice )
322
323 ! create global versions of generic objects from process-local objects
324 ! and destroy process-local generic objects
325 CALL da_res_synop_create_template( template ) ! use template in case
326 ! some tasks have no obs
327 CALL da_y_facade_to_global( re_slice, template, re_glob_slice )
328 CALL da_y_facade_to_global( jo_grad_y_slice, template, jo_grad_y_glob_slice )
329
330 ! create global versions of specific objects
331 ! and destroy global versions of generic objects
332 ! iv first
333 CALL da_iv_type_ins_sonde_sfc_global( re_glob_slice, iv_glob )
334 ! then y_types
335 CALL da_y_type_ins_sonde_sfc_global( re_glob_slice, re_glob )
336 CALL da_y_type_ins_sonde_sfc_global( jo_grad_y_glob_slice, jo_grad_y_glob )
337 ! global versions of specific objects are destroyed in
338 ! free_global_sonde_sfc()
339
340 RETURN
341
342 END SUBROUTINE da_to_global_sonde_sfc
343
344
345 !--- synop synop num_synop
346
347 SUBROUTINE da_y_type_ex_synop( iv, re, slice )
348
349 !------------------------------------------------------------------------------
350 ! PURPOSE: Eliminate redundant code for many obs types.
351 !
352 ! METHOD: Extract all synop obs from y and place them in generic
353 ! object slice.
354 ! Call da_y_facade_free() to deallocate memory allocated here.
355 !------------------------------------------------------------------------------
356 IMPLICIT NONE
357
358 type (ob_type), INTENT(IN ) :: iv ! Innovation vector
359 type (y_type), INTENT(IN ) :: re ! all residual obs
360 type (y_facade_type), INTENT(INOUT) :: slice ! selected residual obs
361 ! Local declarations
362 INTEGER :: n
363
364 CALL da_y_facade_create( slice, iv%num_synop, iv%num_synop_glo )
365 DO n=1, slice%num_obs
366 CALL da_res_generic_set_info( slice%obs(n), &
367 iv%synop(n)%loc%proc_domain, &
368 iv%synop(n)%loc%obs_global_index )
369 CALL da_res_synop_to_generic( re%synop(n), iv%synop(n)%info%levels, &
370 slice%obs(n) )
371 ENDDO
372
373 END SUBROUTINE da_y_type_ex_synop
374
375
376 !--- synop synop num_synop
377
378 SUBROUTINE da_y_type_ins_synop_global( slice_glob, re_glob )
379
380 !------------------------------------------------------------------------------
381 ! PURPOSE: Eliminate redundant code for many obs types.
382 !
383 ! METHOD: Insert obs from generic object slice_glob into
384 ! globally-scoped y_type re_glob. re_glob is
385 ! allocated minimally. Caller must deallocate.
386 ! Memory for global object slice_glob is deallocated here.
387 ! Do not use slice_glob after this call.
388 !------------------------------------------------------------------------------
389 IMPLICIT NONE
390
391 type (y_facade_type), INTENT(INOUT) :: slice_glob ! generic
392 type (y_type), INTENT(INOUT) :: re_glob ! selected residual obs
393 ! Local declarations
394 INTEGER :: n
395
396 ! allocate and initialize obs
397 ! deallocation is done in free_global_synop()
398 ALLOCATE( re_glob%synop(slice_glob%num_obs) )
399 DO n=1, slice_glob%num_obs
400 CALL da_res_synop_from_generic( slice_glob%obs(n), re_glob%synop(n) )
401 ENDDO
402 re_glob%num_synop = slice_glob%num_obs ! duplication!
403 CALL da_y_facade_free( slice_glob )
404
405 END SUBROUTINE da_y_type_ins_synop_global
406
407
408 !--- synop synop num_synop
409
410 SUBROUTINE da_iv_type_ins_synop_global( slice_glob, iv_glob )
411
412 !------------------------------------------------------------------------------
413 ! PURPOSE: Eliminate redundant code for many obs types.
414 !
415 ! METHOD: Insert meta-data from generic object slice_glob into
416 ! globally-scoped ob_type iv_glob. iv_glob is
417 ! allocated minimally. Caller must deallocate.
418 !------------------------------------------------------------------------------
419 IMPLICIT NONE
420
421 type (y_facade_type), INTENT(IN ) :: slice_glob ! selected residual obs
422 type (ob_type), INTENT(INOUT) :: iv_glob ! partial Innovation vector
423 ! Local declarations
424 INTEGER :: n
425
426 ! allocate and initialize needed bits of iv_glob (ugly)
427 iv_glob%num_synop = slice_glob%num_obs
428 iv_glob%num_synop_glo = slice_glob%num_obs_glo
429 ! deallocation is done in free_global_synop()
430 ALLOCATE( iv_glob%synop(iv_glob%num_synop) )
431 DO n=1, iv_glob%num_synop
432 iv_glob%synop(n)%loc%proc_domain = slice_glob%obs(n)%proc_domain
433 iv_glob%synop(n)%loc%obs_global_index = &
434 slice_glob%obs(n)%obs_global_index
435 IF ( da_res_generic_has_vector( slice_glob%obs(n) ) ) THEN
436 iv_glob%synop(n)%info%levels = SIZE(slice_glob%obs(n)%values(1)%ptr)
437 ENDIF
438 ENDDO
439
440 END SUBROUTINE da_iv_type_ins_synop_global
441
442
443 !--- synop synop num_synop
444
445 !------------------------------------------------------------------------------
446 ! PURPOSE: Collect local arrays of residual_synop_type objects into
447 ! global arrays in serial-code storage order. This is used to
448 ! perform bitwise-exact floating-point summations in
449 ! serial-code-order during bitwise-exact testing of
450 ! distributed-memory parallel configurations.
451 !
452 ! METHOD: Indices stowed away during Read_Obs() are used to restore serial
453 ! storage order. Memory for global objects is allocated here.
454 ! Global objects are minimally allocated to save memory.
455 ! Memory is deallocated in free_global_synop().
456 !------------------------------------------------------------------------------
457 SUBROUTINE da_to_global_synop( iv, re, jo_grad_y, &
458 iv_glob, re_glob, jo_grad_y_glob )
459
460 IMPLICIT NONE
461
462 ! task-local objects
463 type (ob_type), INTENT( IN) :: iv ! Innovation vector
464 type (y_type), INTENT( IN) :: re ! residual vector
465 type (y_type), INTENT( IN) :: jo_grad_y ! Grad_y(Jo)
466 ! task-global objects
467 type (ob_type), INTENT(OUT) :: iv_glob ! Innovation vector
468 type (y_type), INTENT(OUT) :: re_glob ! residual vector
469 type (y_type), INTENT(OUT) :: jo_grad_y_glob ! Grad_y(Jo)
470
471 ! Local declarations
472 type (y_facade_type) :: re_slice, re_glob_slice
473 type (y_facade_type) :: jo_grad_y_slice, jo_grad_y_glob_slice
474 type (residual_template_type) :: template ! allocation info
475
476 ! create process-local generic objects from specific objects
477 CALL da_y_type_ex_synop( iv, re, re_slice )
478 CALL da_y_type_ex_synop( iv, jo_grad_y, jo_grad_y_slice )
479
480 ! create global versions of generic objects from process-local objects
481 ! and destroy process-local generic objects
482 CALL da_res_synop_create_template( template ) ! use template in case
483 ! some tasks have no obs
484 CALL da_y_facade_to_global( re_slice, template, re_glob_slice )
485 CALL da_y_facade_to_global( jo_grad_y_slice, template, jo_grad_y_glob_slice )
486
487 ! create global versions of specific objects
488 ! and destroy global versions of generic objects
489 ! iv first
490 CALL da_iv_type_ins_synop_global( re_glob_slice, iv_glob )
491 ! then y_types
492 CALL da_y_type_ins_synop_global( re_glob_slice, re_glob )
493 CALL da_y_type_ins_synop_global( jo_grad_y_glob_slice, jo_grad_y_glob )
494 ! global versions of specific objects are destroyed in
495 ! free_global_synop()
496
497 RETURN
498
499 END SUBROUTINE da_to_global_synop
500