source: tags/ORCHIDEE_1_9_5/ORCHIDEE/src_parallel/orch_write_field.f90 @ 8

Last change on this file since 8 was 8, checked in by orchidee, 14 years ago

import first tag equivalent to CVS orchidee_1_9_5 + OOL_1_9_5
File size: 7.3 KB
Line 
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
7module orch_Write_Field
8 
9  USE constantes
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
247end 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
Note: See TracBrowser for help on using the repository browser.