[64] | 1 | ! Yann Meurdesoif functions for sequentiel tests. |
---|
| 2 | |
---|
| 3 | !- |
---|
| 4 | !- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/orch_write_field.f90,v 1.4 2009/09/17 12:32:29 ssipsl Exp $ |
---|
| 5 | !- |
---|
| 6 | |
---|
| 7 | module orch_Write_Field |
---|
| 8 | |
---|
[257] | 9 | USE data_para |
---|
[64] | 10 | |
---|
| 11 | IMPLICIT NONE |
---|
| 12 | |
---|
| 13 | !- |
---|
| 14 | #include "src_parallel.h" |
---|
| 15 | !- |
---|
| 16 | integer, parameter :: MaxWriteField = 100 |
---|
| 17 | integer, dimension(MaxWriteField),save :: FieldId |
---|
| 18 | integer, dimension(MaxWriteField),save :: FieldVarId |
---|
| 19 | integer, dimension(MaxWriteField),save :: FieldIndex |
---|
| 20 | character(len=255), dimension(MaxWriteField) :: FieldName |
---|
| 21 | |
---|
| 22 | integer, save,dimension(:), allocatable :: Index_Write_Field |
---|
| 23 | integer,save :: iim |
---|
| 24 | integer,save :: jjm |
---|
| 25 | integer,save :: NbPoint |
---|
| 26 | real, parameter :: undef_var=0. |
---|
| 27 | |
---|
| 28 | integer,save :: NbField = 0 |
---|
| 29 | |
---|
| 30 | interface WriteField |
---|
| 31 | module procedure WriteField_4d,WriteField_3d,WriteField_2d,WriteField_1d |
---|
| 32 | end interface WriteField |
---|
| 33 | |
---|
| 34 | interface WriteFieldI |
---|
| 35 | module procedure WriteFieldI_3d,WriteFieldI_2d,WriteFieldI_1d |
---|
| 36 | end interface WriteFieldI |
---|
| 37 | |
---|
| 38 | private :: iim,jjm,NbPoint |
---|
| 39 | contains |
---|
| 40 | |
---|
| 41 | subroutine Init_WriteField(iim0,jjm0,NbPoint0,Index0) |
---|
| 42 | implicit none |
---|
| 43 | integer,intent(in) :: iim0 |
---|
| 44 | integer,intent(in) :: jjm0 |
---|
| 45 | integer,intent(in) :: NbPoint0 |
---|
| 46 | integer,intent(in) :: Index0(NbPoint0) |
---|
| 47 | |
---|
| 48 | iim=iim0 |
---|
| 49 | jjm=jjm0 |
---|
| 50 | Nbpoint=Nbpoint0 |
---|
| 51 | ALLOCATE(Index_Write_Field(NbPoint)) |
---|
| 52 | Index_Write_Field(:)=Index0(:) |
---|
| 53 | end subroutine Init_WriteField |
---|
| 54 | |
---|
| 55 | function GetFieldIndex(name) |
---|
| 56 | implicit none |
---|
| 57 | integer :: GetFieldindex |
---|
| 58 | character(len=*) :: name |
---|
| 59 | |
---|
| 60 | character(len=255) :: TrueName |
---|
| 61 | integer :: i |
---|
| 62 | |
---|
| 63 | |
---|
| 64 | TrueName=TRIM(ADJUSTL(name)) |
---|
| 65 | |
---|
| 66 | GetFieldIndex=-1 |
---|
| 67 | do i=1,NbField |
---|
| 68 | if (TrueName==FieldName(i)) then |
---|
| 69 | GetFieldIndex=i |
---|
| 70 | exit |
---|
| 71 | endif |
---|
| 72 | enddo |
---|
| 73 | end function GetFieldIndex |
---|
| 74 | |
---|
| 75 | subroutine WriteFieldI_3d(name,Field) |
---|
| 76 | implicit none |
---|
| 77 | character(len=*) :: name |
---|
| 78 | real, dimension(:,:,:) :: Field |
---|
| 79 | integer, dimension(3) :: Dim |
---|
| 80 | integer,dimension(4) :: Dim_tmp |
---|
| 81 | integer :: i |
---|
| 82 | |
---|
| 83 | real, allocatable, dimension(:,:,:) :: Field_tmp |
---|
| 84 | |
---|
| 85 | Dim=shape(Field) |
---|
| 86 | allocate(Field_tmp(iim*jjm,Dim(2),dim(3))) |
---|
| 87 | field_tmp(:,:,:)=undef_var |
---|
| 88 | |
---|
| 89 | do i=1,NbPoint |
---|
| 90 | field_tmp(Index_Write_Field(i),:,:)=Field(i,:,:) |
---|
| 91 | enddo |
---|
| 92 | |
---|
| 93 | Dim_tmp(1)=iim |
---|
| 94 | Dim_tmp(2)=jjm |
---|
| 95 | Dim_tmp(3)=dim(2) |
---|
| 96 | Dim_tmp(4)=dim(3) |
---|
| 97 | call WriteField_gen(name,Field_tmp,4,Dim_tmp) |
---|
| 98 | |
---|
| 99 | deallocate(Field_tmp) |
---|
| 100 | end subroutine WriteFieldI_3d |
---|
| 101 | |
---|
| 102 | subroutine WriteFieldI_2d(name,Field) |
---|
| 103 | implicit none |
---|
| 104 | character(len=*) :: name |
---|
| 105 | real, dimension(:,:) :: Field |
---|
| 106 | integer, dimension(2) :: Dim |
---|
| 107 | integer,dimension(3) :: Dim_tmp |
---|
| 108 | integer :: i |
---|
| 109 | |
---|
| 110 | real, allocatable, dimension(:,:) :: Field_tmp |
---|
| 111 | |
---|
| 112 | Dim=shape(Field) |
---|
| 113 | allocate(Field_tmp(iim*jjm,Dim(2))) |
---|
| 114 | field_tmp(:,:)=undef_var |
---|
| 115 | |
---|
| 116 | do i=1,NbPoint |
---|
| 117 | field_tmp(Index_Write_Field(i),:)=Field(i,:) |
---|
| 118 | enddo |
---|
| 119 | |
---|
| 120 | Dim_tmp(1)=iim |
---|
| 121 | Dim_tmp(2)=jjm |
---|
| 122 | Dim_tmp(3)=dim(2) |
---|
| 123 | |
---|
| 124 | call WriteField_gen(name,Field_tmp,3,Dim_tmp) |
---|
| 125 | |
---|
| 126 | deallocate(Field_tmp) |
---|
| 127 | end subroutine WriteFieldI_2d |
---|
| 128 | |
---|
| 129 | subroutine WriteFieldI_1d(name,Field) |
---|
| 130 | implicit none |
---|
| 131 | character(len=*) :: name |
---|
| 132 | real, dimension(:) :: Field |
---|
| 133 | integer, dimension(1) :: Dim |
---|
| 134 | integer,dimension(2) :: Dim_tmp |
---|
| 135 | integer :: i |
---|
| 136 | |
---|
| 137 | real, allocatable, dimension(:) :: Field_tmp |
---|
| 138 | |
---|
| 139 | Dim=shape(Field) |
---|
| 140 | allocate(Field_tmp(iim*jjm)) |
---|
| 141 | field_tmp(:)=undef_var |
---|
| 142 | |
---|
| 143 | do i=1,NbPoint |
---|
| 144 | field_tmp(Index_Write_Field(i))=Field(i) |
---|
| 145 | enddo |
---|
| 146 | |
---|
| 147 | Dim_tmp(1)=iim |
---|
| 148 | Dim_tmp(2)=jjm |
---|
| 149 | |
---|
| 150 | call WriteField_gen(name,Field_tmp,2,Dim_tmp) |
---|
| 151 | |
---|
| 152 | deallocate(Field_tmp) |
---|
| 153 | end subroutine WriteFieldI_1d |
---|
| 154 | |
---|
| 155 | subroutine WriteField_4d(name,Field) |
---|
| 156 | implicit none |
---|
| 157 | character(len=*) :: name |
---|
| 158 | real, dimension(:,:,:,:) :: Field |
---|
| 159 | integer, dimension(4) :: Dim |
---|
| 160 | |
---|
| 161 | Dim=shape(Field) |
---|
| 162 | call WriteField_gen(name,Field,4,Dim) |
---|
| 163 | |
---|
| 164 | end subroutine WriteField_4d |
---|
| 165 | |
---|
| 166 | subroutine WriteField_3d(name,Field) |
---|
| 167 | implicit none |
---|
| 168 | character(len=*) :: name |
---|
| 169 | real, dimension(:,:,:) :: Field |
---|
| 170 | integer, dimension(3) :: Dim |
---|
| 171 | |
---|
| 172 | Dim=shape(Field) |
---|
| 173 | call WriteField_gen(name,Field,3,Dim) |
---|
| 174 | |
---|
| 175 | end subroutine WriteField_3d |
---|
| 176 | |
---|
| 177 | subroutine WriteField_2d(name,Field) |
---|
| 178 | implicit none |
---|
| 179 | character(len=*) :: name |
---|
| 180 | real, dimension(:,:) :: Field |
---|
| 181 | integer, dimension(2) :: Dim |
---|
| 182 | |
---|
| 183 | Dim=shape(Field) |
---|
| 184 | call WriteField_gen(name,Field,2,Dim) |
---|
| 185 | |
---|
| 186 | end subroutine WriteField_2d |
---|
| 187 | |
---|
| 188 | subroutine WriteField_1d(name,Field) |
---|
| 189 | implicit none |
---|
| 190 | character(len=*) :: name |
---|
| 191 | real, dimension(:) :: Field |
---|
| 192 | integer, dimension(1) :: Dim |
---|
| 193 | |
---|
| 194 | Dim=shape(Field) |
---|
| 195 | call WriteField_gen(name,Field,1,Dim) |
---|
| 196 | |
---|
| 197 | end subroutine WriteField_1d |
---|
| 198 | |
---|
| 199 | subroutine CreateNewField(name,NbDim,DimSize) |
---|
| 200 | USE ioipsl |
---|
| 201 | implicit none |
---|
| 202 | include 'netcdf.inc' |
---|
| 203 | character(len=*) :: name |
---|
| 204 | integer :: NbDim |
---|
| 205 | integer :: DimSize(NbDim) |
---|
| 206 | integer :: TabDim(NbDim+1) |
---|
| 207 | integer :: status |
---|
| 208 | |
---|
| 209 | |
---|
| 210 | NbField=NbField+1 |
---|
| 211 | FieldName(NbField)=TRIM(ADJUSTL(name)) |
---|
| 212 | FieldIndex(NbField)=1 |
---|
| 213 | |
---|
| 214 | WRITE(numout,*) 'CREATE_NEW_FIELD ',name,NbDim,DimSize |
---|
| 215 | ! CALL flush(6) |
---|
| 216 | status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField)) |
---|
| 217 | if (NbDim>=1) status = NF_DEF_DIM(FieldId(NbField),'I',DimSize(1),TabDim(1)) |
---|
| 218 | if (NbDim>=2) status = NF_DEF_DIM(FieldId(NbField),'J',DimSize(2),TabDim(2)) |
---|
| 219 | if (NbDim>=3) status = NF_DEF_DIM(FieldId(NbField),'K',DimSize(3),TabDim(3)) |
---|
| 220 | if (NbDim>=4) status = NF_DEF_DIM(FieldId(NbField),'L',DimSize(4),TabDim(4)) |
---|
| 221 | status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(NbDim+1)) |
---|
| 222 | status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,NbDim+1,TabDim,FieldVarId(NbField)) |
---|
| 223 | status = NF_ENDDEF(FieldId(NbField)) |
---|
| 224 | |
---|
| 225 | end subroutine CreateNewField |
---|
| 226 | |
---|
| 227 | function int2str(int) |
---|
| 228 | implicit none |
---|
| 229 | integer, parameter :: MaxLen=10 |
---|
| 230 | integer,intent(in) :: int |
---|
| 231 | character(len=MaxLen) :: int2str |
---|
| 232 | logical :: flag |
---|
| 233 | integer :: i |
---|
| 234 | flag=.true. |
---|
| 235 | |
---|
| 236 | i=int |
---|
| 237 | |
---|
| 238 | int2str='' |
---|
| 239 | do while (flag) |
---|
| 240 | int2str=CHAR(MOD(i,10)+48)//int2str |
---|
| 241 | i=i/10 |
---|
| 242 | if (i==0) flag=.false. |
---|
| 243 | enddo |
---|
| 244 | end function int2str |
---|
| 245 | |
---|
| 246 | |
---|
| 247 | end module Orch_Write_Field |
---|
| 248 | |
---|
| 249 | subroutine WriteField_gen(name,Field,NbDim,DimSize) |
---|
| 250 | use orch_write_field |
---|
| 251 | implicit none |
---|
| 252 | include 'netcdf.inc' |
---|
| 253 | character(len=*) :: name |
---|
| 254 | integer :: NbDim |
---|
| 255 | integer,dimension(NbDim) :: DimSize |
---|
| 256 | real,dimension(*) :: Field |
---|
| 257 | |
---|
| 258 | integer :: status |
---|
| 259 | integer :: ind |
---|
| 260 | integer :: start(NbDim+1) |
---|
| 261 | integer :: count(NbDim+1) |
---|
| 262 | integer :: i |
---|
| 263 | |
---|
| 264 | Ind=GetFieldIndex(name) |
---|
| 265 | if (Ind==-1) then |
---|
| 266 | call CreateNewField(name,NbDim,DimSize) |
---|
| 267 | Ind=GetFieldIndex(name) |
---|
| 268 | else |
---|
| 269 | FieldIndex(Ind)=FieldIndex(Ind)+1 |
---|
| 270 | endif |
---|
| 271 | |
---|
| 272 | do i=1,NbDim |
---|
| 273 | start(i)=1 |
---|
| 274 | count(i)=DimSize(i) |
---|
| 275 | enddo |
---|
| 276 | start(NbDim+1)=FieldIndex(Ind) |
---|
| 277 | count(NbDim+1)=1 |
---|
| 278 | |
---|
| 279 | status = NF_PUT_VARA_DOUBLE(FieldId(Ind),FieldVarId(Ind),start,count,Field) |
---|
| 280 | status = NF_SYNC(FieldId(Ind)) |
---|
| 281 | |
---|
| 282 | end subroutine WriteField_gen |
---|