| 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 |
|---|
