var/da/da_par_util/da_generic_boilerplate.m4

   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 define( macro_y_type_extract,
  15 `!--- $1 $2 $3
  16
  17 SUBROUTINE da_y_type_ex_$1( iv, re, slice )
  18
  19 !------------------------------------------------------------------------------
  20 ! PURPOSE:  Eliminate redundant code for many obs types.
  21 !
  22 ! METHOD:   Extract all $1 obs from y and place them in generic
  23 !           object slice.
  24 !           Call da_y_facade_free() to deallocate memory allocated here.
  25 !------------------------------------------------------------------------------
  26    IMPLICIT NONE
  27
  28    type (iv_type),       INTENT(IN   ) :: iv     ! Innovation vector
  29    type (y_type),        INTENT(IN   ) :: re     ! all residual obs
  30    type (y_facade_type), INTENT(INOUT) :: slice  ! selected residual obs
  31    ! Local declarations
  32    INTEGER :: n
  33
  34    CALL da_y_facade_create( slice, iv%info($1)%nlocal, iv%info($1)%ntotal )
  35    DO n=1, slice%num_obs
  36 stop
  37 !     CALL da_res_generic_set_info( slice%obs(n),                     &
  38 !                                     iv%$1(n)%loc%proc_domain,      &
  39 !                                     iv%$1(n)%loc%obs_global_index )
  40 !     CALL da_res_$2_to_generic( re%$1(n), iv%$1(n)%info%levels, &
  41 !                                     slice%obs(n) )
  42    ENDDO
  43
  44 END SUBROUTINE da_y_type_ex_$1 ' )
  45
  46
  47
  48
  49 define( macro_y_type_insert_global,
  50 `!--- $1 $2 $3
  51
  52 SUBROUTINE da_y_type_ins_$1_global( slice_glob, re_glob )
  53
  54 !------------------------------------------------------------------------------
  55 ! PURPOSE:  Eliminate redundant code for many obs types.
  56 !
  57 ! METHOD:   Insert obs from generic object slice_glob into
  58 !           globally-scoped y_type re_glob.  re_glob is
  59 !           allocated minimally.  Caller must deallocate.
  60 !           Memory for global object slice_glob is deallocated here.
  61 !           Do not use slice_glob after this call.
  62 !------------------------------------------------------------------------------
  63    IMPLICIT NONE
  64
  65    type (y_facade_type), INTENT(INOUT) :: slice_glob ! generic
  66    type (y_type),        INTENT(INOUT) :: re_glob    ! selected residual obs
  67    ! Local declarations
  68    INTEGER :: n
  69
  70    ! allocate and initialize obs
  71    ! deallocation is done in free_global_$1()
  72    ALLOCATE( re_glob%$1(slice_glob%num_obs) )
  73    DO n=1, slice_glob%num_obs
  74      CALL da_res_$2_from_generic( slice_glob%obs(n), re_glob%$1(n) )
  75    ENDDO
  76    re_glob%nlocal($1) = slice_glob%num_obs  ! duplication!
  77    CALL da_y_facade_free( slice_glob )
  78
  79 END SUBROUTINE da_y_type_ins_$1_global ')
  80
  81
  82
  83
  84 define( macro_iv_type_insert_global,
  85 `!--- $1 $2 $3
  86
  87 SUBROUTINE da_iv_type_ins_$1_global( slice_glob, iv_glob )
  88
  89 !------------------------------------------------------------------------------
  90 ! PURPOSE:  Eliminate redundant code for many obs types.
  91 !
  92 ! METHOD:   Insert meta-data from generic object slice_glob into
  93 !           globally-scoped iv_type iv_glob.  iv_glob is
  94 !           allocated minimally.  Caller must deallocate.
  95 !------------------------------------------------------------------------------
  96    IMPLICIT NONE
  97
  98    type (y_facade_type), INTENT(IN   ) :: slice_glob ! selected residual obs
  99    type (iv_type),       INTENT(INOUT) :: iv_glob    ! partial Innovation vector
 100    ! Local declarations
 101    INTEGER :: n
 102
 103    ! allocate and initialize needed bits of iv_glob (ugly)
 104    iv_glob%info($1)%nlocal  = slice_glob%num_obs
 105    iv_glob%info($1)%ntotal = slice_glob%num_obs_glo
 106    ! deallocation is done in free_global_$1()
 107    ALLOCATE( iv_glob%$1(iv_glob%info($1)%nlocal) )
 108    DO n=1, iv_glob%info($1)%nlocal
 109 stop
 110 !     iv_glob%$1(n)%loc%proc_domain = slice_glob%obs(n)%proc_domain
 111 !     iv_glob%$1(n)%loc%obs_global_index = &
 112 !                                        slice_glob%obs(n)%obs_global_index
 113 !     IF ( da_res_generic_has_vector( slice_glob%obs(n) ) ) THEN
 114 !       iv_glob%$1(n)%info%levels = SIZE(slice_glob%obs(n)%values(1)%ptr)
 115 !     ENDIF
 116    ENDDO
 117
 118 END SUBROUTINE da_iv_type_ins_$1_global ' )
 119
 120
 121 define( macro_to_global,
 122 `!--- $1 $2 $3
 123
 124 !------------------------------------------------------------------------------
 125 ! PURPOSE:  Collect local arrays of residual_$2_type objects into
 126 !           global arrays in serial-code storage order.  This is used to
 127 !           perform bitwise-exact floating-point summations in
 128 !           serial-code-order during bitwise-exact testing of
 129 !           distributed-memory parallel configurations.
 130 !
 131 ! METHOD:   Indices stowed away during Read_Obs() are used to restore serial
 132 !           storage order.  Memory for global objects is allocated here.
 133 !           Global objects are minimally allocated to save memory.
 134 !           Memory is deallocated in free_global_$1().
 135 !------------------------------------------------------------------------------
 136   SUBROUTINE da_to_global_$1( iv,      re,      jo_grad_y, &
 137                                   iv_glob, re_glob, jo_grad_y_glob )
 138
 139     IMPLICIT NONE
 140
 141     ! task-local objects
 142     type (iv_type), INTENT( IN) :: iv             ! Innovation vector
 143     type (y_type),  INTENT( IN) :: re             ! residual vector
 144     type (y_type),  INTENT( IN) :: jo_grad_y      ! Grad_y(Jo)
 145     ! task-global objects
 146     type (iv_type), INTENT(OUT) :: iv_glob        ! Innovation vector
 147     type (y_type),  INTENT(OUT) :: re_glob        ! residual vector
 148     type (y_type),  INTENT(OUT) :: jo_grad_y_glob ! Grad_y(Jo)
 149
 150     ! Local declarations
 151     type (y_facade_type) :: re_slice, re_glob_slice
 152     type (y_facade_type) :: jo_grad_y_slice, jo_grad_y_glob_slice
 153     type (residual_template_type) :: template  ! allocation info
 154
 155     ! create process-local generic objects from specific objects
 156     CALL da_y_type_ex_$1( iv, re,        re_slice )
 157     CALL da_y_type_ex_$1( iv, jo_grad_y, jo_grad_y_slice )
 158
 159     ! create global versions of generic objects from process-local objects
 160     ! and destroy process-local generic objects
 161     CALL da_res_$2_create_template( template )  ! use template in case
 162                                                      ! some tasks have no obs
 163     CALL da_y_facade_to_global( re_slice,        template, re_glob_slice )
 164     CALL da_y_facade_to_global( jo_grad_y_slice, template, jo_grad_y_glob_slice )
 165
 166     ! create global versions of specific objects
 167     ! and destroy global versions of generic objects
 168     ! iv first
 169     CALL da_iv_type_ins_$1_global( re_glob_slice, iv_glob )
 170     ! then y_types
 171     CALL da_y_type_ins_$1_global( re_glob_slice,        re_glob )
 172     CALL da_y_type_ins_$1_global( jo_grad_y_glob_slice, jo_grad_y_glob )
 173     ! global versions of specific objects are destroyed in
 174     ! free_global_$1()
 175
 176     RETURN
 177
 178   END SUBROUTINE da_to_global_$1 ' )
 179
 180
 181
 182 macro_y_type_extract(sound,sound,num_sound)
 183
 184
 185 macro_y_type_insert_global(sound,sound,num_sound)
 186
 187
 188 macro_iv_type_insert_global(sound,sound,num_sound)
 189
 190
 191 macro_to_global(sound,sound,num_sound)
 192
 193
 194 macro_y_type_extract(sonde_sfc,synop,num_sound)
 195
 196
 197 macro_y_type_insert_global(sonde_sfc,synop,num_sound)
 198
 199
 200 macro_iv_type_insert_global(sonde_sfc,synop,num_sound)
 201
 202
 203 macro_to_global(sonde_sfc,synop,num_sound)
 204
 205
 206 macro_y_type_extract(synop,synop,num_synop)
 207
 208
 209 macro_y_type_insert_global(synop,synop,num_synop)
 210
 211
 212 macro_iv_type_insert_global(synop,synop,num_synop)
 213
 214
 215 macro_to_global(synop,synop,num_synop)
 216