wrfv2_fire/share/wrf_ext_write_field.F

   1 !WRF:MEDIATION:IO
   2   SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, &
   3                                  DomainDesc,                      &
   4                                  bdy_mask   ,                     &
   5                                  dryrun        ,                  &
   6                                  MemoryOrder,                     &
   7                                  Stagger,                         &
   8                                  Dimname1, Dimname2, Dimname3 ,   &
   9                                  Desc, Units,                     &
  10                                  debug_message ,                              &
  11                                  ds1, de1, ds2, de2, ds3, de3,                &
  12                                  ms1, me1, ms2, me2, ms3, me3,                &
  13                                  ps1, pe1, ps2, pe2, ps3, pe3, Status          )
  14     USE module_io
  15     USE module_wrf_error
  16     USE module_state_description
  17     USE module_timing
  18     IMPLICIT NONE
  19
  20     INTEGER       itrace
  21     integer                                      :: DataHandle
  22     character*(*)                                :: DateStr
  23     character*(*)                                :: Var
  24     integer                                      :: Field(*)
  25     integer                                      :: FieldType
  26     integer                                      :: Comm
  27     integer                                      :: IOComm
  28     integer                                      :: DomainDesc
  29     logical                                      :: dryrun
  30     character*(*)                                :: MemoryOrder
  31     logical, dimension(4)                        :: bdy_mask
  32     character*(*)                                :: Stagger
  33     character*(*)                                :: Dimname1, Dimname2, Dimname3
  34     character*(*)                                :: Desc, Units
  35     character*(*)                                :: debug_message
  36
  37     INTEGER ,       INTENT(IN   ) :: ds1, de1, ds2, de2, ds3, de3, &
  38                                      ms1, me1, ms2, me2, ms3, me3, &
  39                                      ps1, pe1, ps2, pe2, ps3, pe3
  40
  41
  42     INTEGER , DIMENSION(3) :: domain_start , domain_end
  43     INTEGER , DIMENSION(3) :: memory_start , memory_end
  44     INTEGER , DIMENSION(3) :: patch_start , patch_end
  45     CHARACTER*80 , DIMENSION(3) :: dimnames
  46
  47     integer                       ,intent(inout)   :: Status
  48     LOGICAL for_out, horiz_stagger
  49     INTEGER Hndl, io_form
  50     LOGICAL, EXTERNAL :: has_char
  51     INTEGER, EXTERNAL :: use_package
  52
  53     IF ( wrf_at_debug_level( 500 ) ) THEN
  54       call start_timing
  55     ENDIF
  56     domain_start(1) = ds1 ; domain_end(1) = de1 ;
  57     patch_start(1)  = ps1 ; patch_end(1)  = pe1 ;
  58     memory_start(1) = ms1 ; memory_end(1) = me1 ;
  59     domain_start(2) = ds2 ; domain_end(2) = de2 ;
  60     patch_start(2)  = ps2 ; patch_end(2)  = pe2 ;
  61     memory_start(2) = ms2 ; memory_end(2) = me2 ;
  62     domain_start(3) = ds3 ; domain_end(3) = de3 ;
  63     patch_start(3)  = ps3 ; patch_end(3)  = pe3 ;
  64     memory_start(3) = ms3 ; memory_end(3) = me3 ;
  65
  66     dimnames(1) = Dimname1
  67     dimnames(2) = Dimname2
  68     dimnames(3) = Dimname3
  69
  70     CALL debug_io_wrf ( debug_message,DateStr,                          &
  71                         domain_start,domain_end,patch_start,patch_end,  &
  72                         memory_start,memory_end                          )
  73 #if 0
  74     Status = 1
  75     if ( de1 - ds1 < 0 ) return
  76     if ( de2 - ds2 < 0 ) return
  77     if ( de3 - ds3 < 0 ) return
  78     if ( pe1 - ps1 < 0 ) return
  79     if ( pe2 - ps2 < 0 ) return
  80     if ( pe3 - ps3 < 0 ) return
  81     if ( me1 - ms1 < 0 ) return
  82     if ( me2 - ms2 < 0 ) return
  83     if ( me3 - ms3 < 0 ) return
  84 #endif
  85     Status = 0
  86
  87
  88     CALL wrf_write_field (   &
  89                        DataHandle                 &  ! DataHandle
  90                       ,DateStr                    &  ! DateStr
  91                       ,Var                        &  ! Data Name
  92                       ,Field                      &  ! Field
  93                       ,FieldType                  &  ! FieldType
  94                       ,Comm                       &  ! Comm
  95                       ,IOComm                     &  ! IOComm
  96                       ,DomainDesc                 &  ! DomainDesc
  97                       ,bdy_mask                   &  ! bdy_mask
  98                       ,MemoryOrder                &  ! MemoryOrder
  99                       ,Stagger                    &  ! JMMODS 010620
 100                       ,dimnames                   &  ! JMMODS 001109
 101                       ,domain_start               &  ! DomainStart
 102                       ,domain_end                 &  ! DomainEnd
 103                       ,memory_start               &  ! MemoryStart
 104                       ,memory_end                 &  ! MemoryEnd
 105                       ,patch_start                &  ! PatchStart
 106                       ,patch_end                  &  ! PatchEnd
 107                       ,Status )
 108
 109     CALL get_handle ( Hndl, io_form , for_out, DataHandle )
 110
 111     IF ( ( dryrun .AND. ( use_package(io_form) .EQ. IO_NETCDF .OR. &
 112                           use_package(io_form) .EQ. IO_PNETCDF ) ) .OR. &
 113                         ( use_package(io_form) .EQ. IO_PHDF5  )   ) THEN
 114
 115       CALL wrf_put_var_ti_char( &
 116                        DataHandle                 &  ! DataHandle
 117                       ,"description"              &  ! Element
 118                       ,Var                        &  ! Data Name
 119                       ,Desc                       &  ! Data
 120                       ,Status )
 121       CALL wrf_put_var_ti_char( &
 122                        DataHandle                 &  ! DataHandle
 123                       ,"units"                    &  ! Element
 124                       ,Var                        &  ! Data Name
 125                       ,Units                      &  ! Data
 126                       ,Status )
 127       CALL wrf_put_var_ti_char( &
 128                        DataHandle                 &  ! DataHandle
 129                       ,"stagger"                  &  ! Element
 130                       ,Var                        &  ! Data Name
 131                       ,Stagger                    &  ! Data
 132                       ,Status )
 133 #if (EM_CORE == 1)
 134 ! TBH:  Added "coordinates" metadata for GIS folks in RAL.  It is a step
 135 ! TBH:  towards CF.  This change was requested by Jennifer Boehnert based
 136 ! TBH:  upon a suggestion from Nawajish Noman.
 137 ! TBH:  TODO:  This code depends upon longitude and latitude arrays being
 138 ! TBH:         named "XLONG", "XLAT", "XLONG_U", "XLAT_U", "XLONG_V", and
 139 ! TBH:         "XLAT_V" for EM_CORE.  We need a more general way to handle
 140 ! TBH:         this, possibly via the Registry.
 141 ! TBH:  TODO:  Leave this on all the time or make it namelist-selectable?
 142 ! TBH:  TODO:  Use dimnames(*) == south_north || west_east instead of
 143 ! TBH:         MemoryOrder and Stagger?  It would also work for both ARW
 144 ! TBH:         and NMM and be easier to handle via Registry...
 145 !      IF ( ( ( MemoryOrder(1:2) == 'XY' ) .OR. &
 146 !             ( MemoryOrder(1:3) == 'XZY' ) ) .AND. &
 147 !           ( Var(1:5) /= 'XLONG' ) .AND. &
 148 !           ( Var(1:4) /= 'XLAT'  ) ) THEN
 149 ! JM used trim instead, to avoid spurious errors when bounds checking on
 150       IF ( ( ( TRIM(MemoryOrder) == 'XY' ) .OR. &
 151              ( TRIM(MemoryOrder) == 'XZY' ) .OR. &
 152              ( TRIM(MemoryOrder) == 'XYZ' ) ) .AND. &
 153            ( TRIM(Var) /= 'XLONG' ) .AND. &
 154            ( TRIM(Var) /= 'XLAT'  ) ) THEN
 155         horiz_stagger = .FALSE.
 156         IF ( LEN_TRIM(Stagger) == 1 ) THEN
 157           IF ( has_char( Stagger, 'x' ) ) THEN
 158             horiz_stagger = .TRUE.
 159             CALL wrf_put_var_ti_char( &
 160                              DataHandle                 &  ! DataHandle
 161                             ,"coordinates"              &  ! Element
 162                             ,Var                        &  ! Data Name
 163                             ,"XLONG_U XLAT_U"           &  ! Data
 164                             ,Status )
 165           ELSE IF ( has_char( Stagger, 'y' ) ) THEN
 166             horiz_stagger = .TRUE.
 167             CALL wrf_put_var_ti_char( &
 168                              DataHandle                 &  ! DataHandle
 169                             ,"coordinates"              &  ! Element
 170                             ,Var                        &  ! Data Name
 171                             ,"XLONG_V XLAT_V"           &  ! Data
 172                             ,Status )
 173           ENDIF
 174         ENDIF
 175         IF ( .NOT. horiz_stagger ) THEN
 176           CALL wrf_put_var_ti_char( &
 177                            DataHandle                 &  ! DataHandle
 178                           ,"coordinates"              &  ! Element
 179                           ,Var                        &  ! Data Name
 180                           ,"XLONG XLAT"               &  ! Data
 181                           ,Status )
 182         ENDIF
 183       ENDIF
 184 #endif
 185     ENDIF
 186
 187     IF ( wrf_at_debug_level(300) ) THEN
 188       WRITE(wrf_err_message,*) debug_message,' Status = ',Status
 189       CALL wrf_message ( TRIM(wrf_err_message) )
 190     ENDIF
 191
 192     IF ( wrf_at_debug_level( 500 ) ) THEN
 193       CALL end_timing('wrf_ext_write_field')
 194     ENDIF
 195
 196   END SUBROUTINE wrf_ext_write_field