share/wrf_ext_write_field.F

   1 !WRF:MEDIATION:IO
   2   SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var       &
   3                                 ,Field                            &
   4                                 ,idx4, idx5, idx6, idx7           &
   5                                 ,nx4 , nx5 , nx6                  &
   6                                 ,TypeSizeInBytes                  &
   7                                 ,FieldType,grid                   &
   8                                 ,DomainDesc                       &
   9                                 ,bdy_mask                         &
  10                                 ,dryrun                           &
  11                                 ,MemoryOrder                      &
  12                                 ,Stagger                          &
  13                                 ,Dimname1, Dimname2, Dimname3     &
  14                                 ,Desc, Units                      &
  15                                 ,debug_message                                &
  16                                 ,ds1, de1, ds2, de2, ds3, de3                 &
  17                                 ,ms1, me1, ms2, me2, ms3, me3                 &
  18                                 ,ps1, pe1, ps2, pe2, ps3, pe3, Status          )
  19     USE module_io
  20     USE module_wrf_error
  21     USE module_state_description
  22     USE module_timing
  23     USE module_domain
  24
  25     IMPLICIT NONE
  26
  27     INTEGER, INTENT(IN)       :: idx4, idx5, idx6, idx7
  28     INTEGER, INTENT(IN)       :: nx4 , nx5 , nx6
  29     INTEGER, INTENT(IN)       :: TypeSizeInBytes
  30     INTEGER               ,INTENT(IN   )         :: DataHandle
  31     CHARACTER*(*)         ,INTENT(IN   )         :: DateStr
  32     CHARACTER*(*)         ,INTENT(IN   )         :: Var
  33     INTEGER               ,INTENT(IN   )         :: Field(*)
  34     INTEGER               ,INTENT(IN   )         :: FieldType
  35     TYPE(domain)                                 :: grid
  36     INTEGER               ,INTENT(IN   )         :: DomainDesc
  37     LOGICAL               ,INTENT(IN   )         :: dryrun
  38     CHARACTER*(*)         ,INTENT(IN   )         :: MemoryOrder
  39     LOGICAL, DIMENSION(4) ,INTENT(IN   )         :: bdy_mask
  40     CHARACTER*(*)         ,INTENT(IN   )         :: Stagger
  41     CHARACTER*(*)         ,INTENT(IN   )         :: Dimname1, Dimname2, Dimname3
  42     CHARACTER*(*)         ,INTENT(IN   )         :: Desc, Units
  43     CHARACTER*(*)         ,INTENT(IN   )         :: debug_message
  44
  45     INTEGER ,       INTENT(IN   ) :: ds1, de1, ds2, de2, ds3, de3, &
  46                                      ms1, me1, ms2, me2, ms3, me3, &
  47                                      ps1, pe1, ps2, pe2, ps3, pe3
  48     INTEGER ,       INTENT(INOUT) :: Status
  49 ! Local
  50     INTEGER  tsfac  ! Type size factor
  51     CHARACTER*256 mess
  52
  53     tsfac = TypeSizeInBytes / IWORDSIZE
  54
  55     IF ( tsfac .LE. 0 ) THEN
  56       CALL wrf_message('wrf_ext_write_field_arr')
  57       WRITE(mess,*)'Internal error: email this message to wrfhelp@ucar.edu ',TypeSizeInBytes,IWORDSIZE
  58       CALL wrf_error_fatal(mess)
  59     ENDIF
  60
  61     CALL wrf_ext_write_field(    DataHandle,DateStr,Var           &
  62                                 ,Field(1                                                            &
  63                                       +tsfac*(0                                                     &
  64                                       +(idx4-1)*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1)                 &
  65                                       +(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1)             &
  66                                       +(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1)         &
  67                                       +(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1)))   &
  68                                 ,FieldType,grid                   &
  69                                 ,DomainDesc                       &
  70                                 ,bdy_mask                         &
  71                                 ,dryrun                           &
  72                                 ,MemoryOrder                      &
  73                                 ,Stagger                          &
  74                                 ,Dimname1, Dimname2, Dimname3     &
  75                                 ,Desc, Units                      &
  76                                 ,debug_message                                &
  77                                 ,ds1, de1, ds2, de2, ds3, de3                 &
  78                                 ,ms1, me1, ms2, me2, ms3, me3                 &
  79                                 ,ps1, pe1, ps2, pe2, ps3, pe3, Status          )
  80
  81   END SUBROUTINE wrf_ext_write_field_arr
  82
  83
  84   SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,grid, &
  85                                  DomainDesc,                      &
  86                                  bdy_mask   ,                     &
  87                                  dryrun        ,                  &
  88                                  MemoryOrder,                     &
  89                                  Stagger,                         &
  90                                  Dimname1, Dimname2, Dimname3 ,   &
  91                                  Desc, Units,                     &
  92                                  debug_message ,                              &
  93                                  ds1, de1, ds2, de2, ds3, de3,                &
  94                                  ms1, me1, ms2, me2, ms3, me3,                &
  95                                  ps1, pe1, ps2, pe2, ps3, pe3, Status          )
  96     USE module_io
  97     USE module_wrf_error
  98     USE module_state_description
  99     USE module_timing
 100     USE module_domain
 101
 102     IMPLICIT NONE
 103
 104     INTEGER               ,INTENT(IN   )         :: DataHandle
 105     CHARACTER*(*)         ,INTENT(IN   )         :: DateStr
 106     CHARACTER*(*)         ,INTENT(IN   )         :: Var
 107     INTEGER               ,INTENT(IN   )         :: Field(*)
 108     INTEGER               ,INTENT(IN   )         :: FieldType
 109     TYPE(domain)                                 :: grid
 110     INTEGER               ,INTENT(IN   )         :: DomainDesc
 111     LOGICAL               ,INTENT(IN   )         :: dryrun
 112     CHARACTER*(*)         ,INTENT(IN   )         :: MemoryOrder
 113     LOGICAL, DIMENSION(4) ,INTENT(IN   )         :: bdy_mask
 114     CHARACTER*(*)         ,INTENT(IN   )         :: Stagger
 115     CHARACTER*(*)         ,INTENT(IN   )         :: Dimname1, Dimname2, Dimname3
 116     CHARACTER*(*)         ,INTENT(IN   )         :: Desc, Units
 117     CHARACTER*(*)         ,INTENT(IN   )         :: debug_message
 118
 119     INTEGER ,       INTENT(IN   ) :: ds1, de1, ds2, de2, ds3, de3, &
 120                                      ms1, me1, ms2, me2, ms3, me3, &
 121                                      ps1, pe1, ps2, pe2, ps3, pe3
 122
 123 ! Local
 124     INTEGER , DIMENSION(3) :: domain_start , domain_end
 125     INTEGER , DIMENSION(3) :: memory_start , memory_end
 126     INTEGER , DIMENSION(3) :: patch_start , patch_end
 127     CHARACTER*80 , DIMENSION(3) :: dimnames
 128
 129     integer                       ,intent(inout)   :: Status
 130     LOGICAL for_out, horiz_stagger
 131     INTEGER io_form
 132     LOGICAL, EXTERNAL :: has_char
 133     INTEGER, EXTERNAL :: use_package
 134     INTEGER Hndl
 135
 136     IF ( wrf_at_debug_level( 500 ) ) THEN
 137       call start_timing
 138     ENDIF
 139     domain_start(1) = ds1 ; domain_end(1) = de1 ;
 140     patch_start(1)  = ps1 ; patch_end(1)  = pe1 ;
 141     memory_start(1) = ms1 ; memory_end(1) = me1 ;
 142     domain_start(2) = ds2 ; domain_end(2) = de2 ;
 143     patch_start(2)  = ps2 ; patch_end(2)  = pe2 ;
 144     memory_start(2) = ms2 ; memory_end(2) = me2 ;
 145     domain_start(3) = ds3 ; domain_end(3) = de3 ;
 146     patch_start(3)  = ps3 ; patch_end(3)  = pe3 ;
 147     memory_start(3) = ms3 ; memory_end(3) = me3 ;
 148
 149     dimnames(1) = Dimname1
 150     dimnames(2) = Dimname2
 151     dimnames(3) = Dimname3
 152
 153     CALL debug_io_wrf ( debug_message,DateStr,                          &
 154                         domain_start,domain_end,patch_start,patch_end,  &
 155                         memory_start,memory_end                          )
 156 #if 0
 157     Status = 1
 158     if ( de1 - ds1 < 0 ) return
 159     if ( de2 - ds2 < 0 ) return
 160     if ( de3 - ds3 < 0 ) return
 161     if ( pe1 - ps1 < 0 ) return
 162     if ( pe2 - ps2 < 0 ) return
 163     if ( pe3 - ps3 < 0 ) return
 164     if ( me1 - ms1 < 0 ) return
 165     if ( me2 - ms2 < 0 ) return
 166     if ( me3 - ms3 < 0 ) return
 167 #endif
 168     Status = 0
 169
 170     CALL wrf_write_field (   &
 171                        DataHandle                 &  ! DataHandle
 172                       ,DateStr                    &  ! DateStr
 173                       ,Var                        &  ! Data Name
 174                       ,Field                      &  ! Field
 175                       ,FieldType                  &  ! FieldType
 176                       ,grid                       &  ! grid
 177                       ,DomainDesc                 &  ! DomainDesc
 178                       ,bdy_mask                   &  ! bdy_mask
 179                       ,MemoryOrder                &  ! MemoryOrder
 180                       ,Stagger                    &  ! JMMODS 010620
 181                       ,dimnames                   &  ! JMMODS 001109
 182                       ,domain_start               &  ! DomainStart
 183                       ,domain_end                 &  ! DomainEnd
 184                       ,memory_start               &  ! MemoryStart
 185                       ,memory_end                 &  ! MemoryEnd
 186                       ,patch_start                &  ! PatchStart
 187                       ,patch_end                  &  ! PatchEnd
 188                       ,Status )
 189
 190     CALL get_handle ( Hndl, io_form , for_out, DataHandle )
 191
 192     IF ( ( dryrun .AND. ( use_package(io_form) .EQ. IO_NETCDF .OR. &
 193                           use_package(io_form) .EQ. IO_NETCDFPAR .OR. &
 194                           use_package(io_form) .EQ. IO_PIO    .OR. &
 195                           use_package(io_form) .EQ. IO_ADIOS2 .OR. &
 196                           use_package(io_form) .EQ. IO_PNETCDF ) ) .OR. &
 197                         ( use_package(io_form) .EQ. IO_PHDF5  )   ) THEN
 198
 199       CALL wrf_put_var_ti_char( &
 200                        DataHandle                 &  ! DataHandle
 201                       ,"description"              &  ! Element
 202                       ,Var                        &  ! Data Name
 203                       ,Desc                       &  ! Data
 204                       ,Status )
 205       CALL wrf_put_var_ti_char( &
 206                        DataHandle                 &  ! DataHandle
 207                       ,"units"                    &  ! Element
 208                       ,Var                        &  ! Data Name
 209                       ,Units                      &  ! Data
 210                       ,Status )
 211       CALL wrf_put_var_ti_char( &
 212                        DataHandle                 &  ! DataHandle
 213                       ,"stagger"                  &  ! Element
 214                       ,Var                        &  ! Data Name
 215                       ,Stagger                    &  ! Data
 216                       ,Status )
 217 #if (EM_CORE == 1)
 218 ! TBH:  Added "coordinates" metadata for GIS folks in RAL.  It is a step
 219 ! TBH:  towards CF.  This change was requested by Jennifer Boehnert based
 220 ! TBH:  upon a suggestion from Nawajish Noman.
 221 ! TBH:  TODO:  This code depends upon longitude and latitude arrays being
 222 ! TBH:         named "XLONG", "XLAT", "XLONG_U", "XLAT_U", "XLONG_V", and
 223 ! TBH:         "XLAT_V" for EM_CORE.  We need a more general way to handle
 224 ! TBH:         this, possibly via the Registry.
 225 ! TBH:  TODO:  Use dimnames(*) == south_north || west_east instead of
 226 ! TBH:         MemoryOrder and Stagger?
 227
 228       IF ( ( TRIM(MemoryOrder) == 'XY' ) .AND. &
 229          ( ( TRIM(Var) == 'XLONG'   ) .OR. &
 230            ( TRIM(Var) == 'XLAT'    ) .OR. &
 231            ( TRIM(Var) == 'XLONG_U' ) .OR. &
 232            ( TRIM(Var) == 'XLAT_U'  ) .OR. &
 233            ( TRIM(Var) == 'XLONG_V' ) .OR. &
 234            ( TRIM(Var) == 'XLAT_V'  ) ) ) THEN
 235         horiz_stagger = .FALSE.
 236         IF ( LEN_TRIM(Stagger) == 1 ) THEN
 237           IF ( has_char( Stagger, 'x' ) ) THEN
 238             horiz_stagger = .TRUE.
 239             CALL wrf_put_var_ti_char( &
 240                              DataHandle                 &  ! DataHandle
 241                             ,"coordinates"              &  ! Element
 242                             ,Var                        &  ! Data Name
 243                             ,"XLONG_U XLAT_U"           &  ! Data
 244                             ,Status )
 245           ELSE IF ( has_char( Stagger, 'y' ) ) THEN
 246             horiz_stagger = .TRUE.
 247             CALL wrf_put_var_ti_char( &
 248                              DataHandle                 &  ! DataHandle
 249                             ,"coordinates"              &  ! Element
 250                             ,Var                        &  ! Data Name
 251                             ,"XLONG_V XLAT_V"           &  ! Data
 252                             ,Status )
 253           ENDIF
 254         ENDIF
 255         IF ( .NOT. horiz_stagger ) THEN
 256           CALL wrf_put_var_ti_char( &
 257                            DataHandle                 &  ! DataHandle
 258                           ,"coordinates"              &  ! Element
 259                           ,Var                        &  ! Data Name
 260                           ,"XLONG XLAT"               &  ! Data
 261                           ,Status )
 262         ENDIF
 263       ELSE IF ( ( TRIM(MemoryOrder) == 'XY'  ) .OR. &
 264                 ( TRIM(MemoryOrder) == 'XZY' ) .OR. &
 265                 ( TRIM(MemoryOrder) == 'XYZ' ) ) THEN
 266         horiz_stagger = .FALSE.
 267         IF ( LEN_TRIM(Stagger) == 1 ) THEN
 268           IF ( has_char( Stagger, 'x' ) ) THEN
 269             horiz_stagger = .TRUE.
 270             CALL wrf_put_var_ti_char( &
 271                              DataHandle                 &  ! DataHandle
 272                             ,"coordinates"              &  ! Element
 273                             ,Var                        &  ! Data Name
 274                             ,"XLONG_U XLAT_U XTIME"     &  ! Data
 275                             ,Status )
 276           ELSE IF ( has_char( Stagger, 'y' ) ) THEN
 277             horiz_stagger = .TRUE.
 278             CALL wrf_put_var_ti_char( &
 279                              DataHandle                 &  ! DataHandle
 280                             ,"coordinates"              &  ! Element
 281                             ,Var                        &  ! Data Name
 282                             ,"XLONG_V XLAT_V XTIME"     &  ! Data
 283                             ,Status )
 284           ENDIF
 285         ENDIF
 286         IF ( .NOT. horiz_stagger ) THEN
 287           CALL wrf_put_var_ti_char( &
 288                            DataHandle                 &  ! DataHandle
 289                           ,"coordinates"              &  ! Element
 290                           ,Var                        &  ! Data Name
 291                           ,"XLONG XLAT XTIME"         &  ! Data
 292                           ,Status )
 293         ENDIF
 294       ENDIF
 295 #endif
 296     ENDIF
 297
 298     IF ( wrf_at_debug_level(300) ) THEN
 299       WRITE(wrf_err_message,*) debug_message,' Status = ',Status
 300       CALL wrf_message ( TRIM(wrf_err_message) )
 301     ENDIF
 302
 303     IF ( wrf_at_debug_level( 500 ) ) THEN
 304       CALL end_timing('wrf_ext_write_field')
 305     ENDIF
 306
 307   END SUBROUTINE wrf_ext_write_field