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