frame/module_alloc_space.h

   1    SUBROUTINE ROUTINENAME ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , &
   2                                   sd31, ed31, sd32, ed32, sd33, ed33, &
   3                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
   4                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
   5                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
   6                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
   7                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
   8                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
   9
  10       USE module_domain_type
  11       USE module_configure, ONLY : model_config_rec, grid_config_rec_type, in_use_for_config, model_to_grid_config_rec
  12 !      USE module_state_description
  13       USE module_scalar_tables ! this includes module_state_description too
  14
  15       IMPLICIT NONE
  16
  17       !  Input data.
  18
  19       TYPE(domain)               , POINTER          :: grid
  20       INTEGER , INTENT(IN)            :: id
  21       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
  22       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
  23       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
  24       INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33
  25       INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
  26       INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
  27       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
  28       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
  29
  30       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
  31       ! e.g. to set both 1st and second time level, use 3
  32       !      to set only 1st                        use 1
  33       !      to set only 2st                        use 2
  34       INTEGER , INTENT(IN)            :: tl_in
  35
  36       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
  37       ! false otherwise (all allocated, modulo tl above)
  38       LOGICAL , INTENT(IN)            :: inter_domain_in, okay_to_alloc_in
  39
  40       INTEGER(KIND=8) , INTENT(INOUT)         :: num_bytes_allocated
  41
  42
  43       !  Local data.
  44       INTEGER idum1, idum2, spec_bdy_width
  45       REAL    initial_data_value
  46       CHARACTER (LEN=256) message
  47       INTEGER tl
  48       LOGICAL inter_domain, okay_to_alloc
  49       INTEGER setinitval
  50       INTEGER sr_x, sr_y
  51
  52       !declare ierr variable for error checking ALLOCATE calls
  53       INTEGER ierr
  54
  55       INTEGER                              :: loop
  56       INTEGER(KIND=8)                      :: nba ! number of bytes allocated per variable
  57       CHARACTER(LEN=256)                   :: message_string
  58
  59    ! Local data
  60
  61       TYPE ( grid_config_rec_type ) :: config_flags
  62
  63       INTEGER                         :: k_start , k_end, its, ite, jts, jte
  64       INTEGER                         :: ids , ide , jds , jde , kds , kde , &
  65                                          ims , ime , jms , jme , kms , kme , &
  66                                          ips , ipe , jps , jpe , kps , kpe
  67
  68       INTEGER                         :: sids , side , sjds , sjde , skds , skde , &
  69                                          sims , sime , sjms , sjme , skms , skme , &
  70                                          sips , sipe , sjps , sjpe , skps , skpe
  71
  72
  73       INTEGER ::              imsx, imex, jmsx, jmex, kmsx, kmex,    &
  74                               ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
  75                               imsy, imey, jmsy, jmey, kmsy, kmey,    &
  76                               ipsy, ipey, jpsy, jpey, kpsy, kpey
  77
  78       data_ordering : SELECT CASE ( model_data_order )
  79          CASE  ( DATA_ORDER_XYZ )
  80              ids = sd31 ; ide = ed31 ; jds = sd32 ; jde = ed32 ; kds = sd33 ; kde = ed33 ;
  81              ims = sm31 ; ime = em31 ; jms = sm32 ; jme = em32 ; kms = sm33 ; kme = em33 ;
  82              ips = sp31 ; ipe = ep31 ; jps = sp32 ; jpe = ep32 ; kps = sp33 ; kpe = ep33 ;
  83              imsx = sm31x ; imex = em31x ; jmsx = sm32x ; jmex = em32x ; kmsx = sm33x ; kmex = em33x ;
  84              ipsx = sp31x ; ipex = ep31x ; jpsx = sp32x ; jpex = ep32x ; kpsx = sp33x ; kpex = ep33x ;
  85              imsy = sm31y ; imey = em31y ; jmsy = sm32y ; jmey = em32y ; kmsy = sm33y ; kmey = em33y ;
  86              ipsy = sp31y ; ipey = ep31y ; jpsy = sp32y ; jpey = ep32y ; kpsy = sp33y ; kpey = ep33y ;
  87          CASE  ( DATA_ORDER_YXZ )
  88              ids = sd32  ; ide = ed32  ; jds = sd31  ; jde = ed31  ; kds = sd33  ; kde = ed33  ;
  89              ims = sm32  ; ime = em32  ; jms = sm31  ; jme = em31  ; kms = sm33  ; kme = em33  ;
  90              ips = sp32  ; ipe = ep32  ; jps = sp31  ; jpe = ep31  ; kps = sp33  ; kpe = ep33  ;
  91              imsx = sm32x  ; imex = em32x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm33x  ; kmex = em33x  ;
  92              ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp33x  ; kpex = ep33x  ;
  93              imsy = sm32y  ; imey = em32y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm33y  ; kmey = em33y  ;
  94              ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp33y  ; kpey = ep33y  ;
  95          CASE  ( DATA_ORDER_ZXY )
  96              ids = sd32  ; ide = ed32  ; jds = sd33  ; jde = ed33  ; kds = sd31  ; kde = ed31  ;
  97              ims = sm32  ; ime = em32  ; jms = sm33  ; jme = em33  ; kms = sm31  ; kme = em31  ;
  98              ips = sp32  ; ipe = ep32  ; jps = sp33  ; jpe = ep33  ; kps = sp31  ; kpe = ep31  ;
  99              imsx = sm32x  ; imex = em32x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm31x  ; kmex = em31x  ;
 100              ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp31x  ; kpex = ep31x  ;
 101              imsy = sm32y  ; imey = em32y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm31y  ; kmey = em31y  ;
 102              ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp31y  ; kpey = ep31y  ;
 103          CASE  ( DATA_ORDER_ZYX )
 104              ids = sd33  ; ide = ed33  ; jds = sd32  ; jde = ed32  ; kds = sd31  ; kde = ed31  ;
 105              ims = sm33  ; ime = em33  ; jms = sm32  ; jme = em32  ; kms = sm31  ; kme = em31  ;
 106              ips = sp33  ; ipe = ep33  ; jps = sp32  ; jpe = ep32  ; kps = sp31  ; kpe = ep31  ;
 107              imsx = sm33x  ; imex = em33x  ; jmsx = sm32x  ; jmex = em32x  ; kmsx = sm31x  ; kmex = em31x  ;
 108              ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp32x  ; jpex = ep32x  ; kpsx = sp31x  ; kpex = ep31x  ;
 109              imsy = sm33y  ; imey = em33y  ; jmsy = sm32y  ; jmey = em32y  ; kmsy = sm31y  ; kmey = em31y  ;
 110              ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp32y  ; jpey = ep32y  ; kpsy = sp31y  ; kpey = ep31y  ;
 111          CASE  ( DATA_ORDER_XZY )
 112              ids = sd31  ; ide = ed31  ; jds = sd33  ; jde = ed33  ; kds = sd32  ; kde = ed32  ;
 113              ims = sm31  ; ime = em31  ; jms = sm33  ; jme = em33  ; kms = sm32  ; kme = em32  ;
 114              ips = sp31  ; ipe = ep31  ; jps = sp33  ; jpe = ep33  ; kps = sp32  ; kpe = ep32  ;
 115              imsx = sm31x  ; imex = em31x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm32x  ; kmex = em32x  ;
 116              ipsx = sp31x  ; ipex = ep31x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp32x  ; kpex = ep32x  ;
 117              imsy = sm31y  ; imey = em31y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm32y  ; kmey = em32y  ;
 118              ipsy = sp31y  ; ipey = ep31y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp32y  ; kpey = ep32y  ;
 119          CASE  ( DATA_ORDER_YZX )
 120              ids = sd33  ; ide = ed33  ; jds = sd31  ; jde = ed31  ; kds = sd32  ; kde = ed32  ;
 121              ims = sm33  ; ime = em33  ; jms = sm31  ; jme = em31  ; kms = sm32  ; kme = em32  ;
 122              ips = sp33  ; ipe = ep33  ; jps = sp31  ; jpe = ep31  ; kps = sp32  ; kpe = ep32  ;
 123              imsx = sm33x  ; imex = em33x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm32x  ; kmex = em32x  ;
 124              ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp32x  ; kpex = ep32x  ;
 125              imsy = sm33y  ; imey = em33y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm32y  ; kmey = em32y  ;
 126              ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp32y  ; kpey = ep32y  ;
 127       END SELECT data_ordering
 128
 129       CALL model_to_grid_config_rec ( id , model_config_rec , config_flags )
 130
 131       CALL nl_get_sr_x( id , sr_x )
 132       CALL nl_get_sr_y( id , sr_y )
 133
 134       tl = tl_in
 135       inter_domain = inter_domain_in
 136       okay_to_alloc = okay_to_alloc_in
 137
 138 #if ( RWORDSIZE == 8 )
 139       initial_data_value = 0.
 140 #else
 141       CALL get_initial_data_value ( initial_data_value )
 142 #endif
 143
 144 #ifdef NO_INITIAL_DATA_VALUE
 145       setinitval = 0
 146 #else
 147       setinitval = setinitval_in
 148 #endif
 149
 150       CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
 151
 152 # include "allocs.inc"
 153
 154    END SUBROUTINE ROUTINENAME