source: codes/icosagcm/trunk/src/initial/etat0_database.f90 @ 548

Last change on this file since 548 was 548, checked in by dubos, 7 years ago

trunk : reorganize source tree
File size: 4.8 KB
Line 
1MODULE etat0_database_mod
2
3
4CONTAINS
5
6  SUBROUTINE init_etat0
7  USE xios_mod
8  USE omp_para
9  IMPLICIT NONE
10 
11    IF (is_omp_master) THEN
12      CALL xios_set_fieldgroup_attr("read_fields",enabled=.TRUE.)
13      CALL xios_set_filegroup_attr("read_files",enabled=.TRUE.)
14    ENDIF
15  END SUBROUTINE init_etat0
16
17  SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
18  USE icosa
19  USE restart_mod
20  USE wind_mod
21  USE write_field_mod
22  USE time_mod
23  USE transfert_mod
24  USE xios_mod
25  USE write_field_mod
26  USE vertical_remap_mod
27  USE theta2theta_rhodz_mod
28  USE qsat_mod
29  USE pression_mod
30  USE omp_para
31  IMPLICIT NONE
32    TYPE(t_field),POINTER :: f_ps(:)
33    TYPE(t_field),POINTER :: f_phis(:)
34    TYPE(t_field),POINTER :: f_theta_rhodz(:)
35    TYPE(t_field),POINTER :: f_u(:)
36    TYPE(t_field),POINTER :: f_q(:)
37
38    TYPE(t_field),POINTER,SAVE :: f_ulon_reg(:)
39    TYPE(t_field),POINTER,SAVE :: f_ulat_reg(:)
40    TYPE(t_field),POINTER,SAVE :: f_temp_reg(:)
41    TYPE(t_field),POINTER,SAVE :: f_q_reg(:)
42
43    TYPE(t_field),POINTER,SAVE :: f_ts(:)
44    TYPE(t_field),POINTER,SAVE :: f_z(:)
45    TYPE(t_field),POINTER,SAVE :: f_ulon(:)
46    TYPE(t_field),POINTER,SAVE :: f_ulat(:)
47    TYPE(t_field),POINTER,SAVE :: f_temp(:)
48    TYPE(t_field),POINTER,SAVE :: f_q1(:)
49    TYPE(t_field),POINTER,SAVE :: f_qsat(:)
50    TYPE(t_field),POINTER,SAVE :: f_p(:)
51    INTEGER :: nb_level
52    REAL,ALLOCATABLE:: levels(:)
53    INTEGER :: ind
54
55    CALL xios_read_field("relief_db",f_phis)
56   
57    CALL writeField("relief_out",f_phis,once=.TRUE.)
58
59    DO ind=1,ndomain
60      IF (.NOT. assigned_domain(ind)) CYCLE
61      f_phis(ind)%rval2d(:)=f_phis(ind)%rval2d(:)*g     
62    ENDDO
63
64
65    IF (is_omp_master) CALL xios_get_axis_attr("lev_ecdyn",n_glo=nb_level)
66    CALL bcast_omp(nb_level)
67    ALLOCATE(levels(nb_level))
68
69    IF (is_omp_master) CALL xios_get_axis_attr("lev_ecdyn",value=levels)
70    CALL bcast_omp(levels)
71   
72    levels=levels*100  ! hectoPascal -> Pascal
73 
74    CALL allocate_field(f_ts, field_t, type_real, name="ts")
75    CALL allocate_field(f_z, field_t, type_real, name="z")
76    CALL allocate_field(f_ulon_reg, field_t, type_real,nb_level)
77    CALL allocate_field(f_ulat_reg, field_t, type_real,nb_level)
78    CALL allocate_field(f_temp_reg, field_t, type_real,nb_level)
79    CALL allocate_field(f_q_reg,    field_t, type_real,nb_level)
80   
81    CALL allocate_field(f_q1,    field_t, type_real,llm)
82    CALL allocate_field(f_qsat,  field_t, type_real,llm)
83    CALL allocate_field(f_p,  field_t, type_real,llm+1)
84    CALL allocate_field(f_temp,  field_t, type_real,llm)
85    CALL allocate_field(f_ulon,  field_t, type_real,llm)
86    CALL allocate_field(f_ulat,  field_t, type_real,llm)
87
88    CALL xios_read_field("z_db",f_z)
89    CALL xios_read_field("ps_db",f_ps)
90    CALL xios_read_field("ts_db",f_ts)
91    CALL writeField("ps_out",f_ps)
92
93!$OMP BARRIER
94   
95!    CALL writeField("phis_out",f_phis,once=.TRUE.)
96!    CALL writeField("ts_out",f_ts,once=.TRUE.)
97
98! make correction to ps due to relief at higher resolution
99! difference with LMDZ : tsol is taken from ECDYN.NC and not from ECPHY
100    DO ind=1,ndomain
101      IF (.NOT. assigned_domain(ind)) CYCLE
102      f_ps(ind)%rval2d(:)=f_ps(ind)%rval2d(:)*(1.+(f_z(ind)%rval2d(:)-f_phis(ind)%rval2d(:))/287.0/f_ts(ind)%rval2d(:))
103    ENDDO
104    CALL transfert_request(f_ps,req_i0) 
105    CALL writeField("ps_out",f_ps)
106   
107   
108
109    CALL xios_read_field("temp_db",f_temp_reg)
110    CALL vertical_remap(levels,f_temp_reg,f_ps,f_temp)
111    CALL transfert_request(f_temp,req_i0) 
112    CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz)
113
114    CALL xios_read_field("u_db",f_ulon_reg)
115    CALL vertical_remap(levels,f_ulon_reg,f_ps,f_ulon)
116    CALL xios_read_field("v_db",f_ulat_reg)
117    CALL vertical_remap(levels,f_ulat_reg,f_ps,f_ulat)
118    CALL transfert_request(f_ulat,req_i0) 
119    CALL transfert_request(f_ulon,req_i0) 
120    CALL ulonlat2un(f_ulon, f_ulat,f_u)
121
122    CALL xios_read_field("q_db",f_q_reg)
123    CALL vertical_remap(levels,f_q_reg,f_ps,f_q1)
124
125    CALL pression(f_ps,f_p)
126! difference with LMDZ : for qsat, pressure at mid layer is computed as a mean value pmid=(p(l)+p(l+1))/2   
127    CALL qsat(f_temp,f_p,f_qsat)
128    CALL transfert_request(f_qsat,req_i0) 
129
130    DO ind=1,ndomain
131      IF (.NOT. assigned_domain(ind)) CYCLE
132      f_q(ind)%rval4d(:,:,:)=1e-6
133      f_q(ind)%rval4d(:,:,1)=f_q1(ind)%rval3d(:,:)*f_qsat(ind)%rval3d(:,:)*0.01
134      WHERE(f_q(ind)%rval4d(:,:,1)<0) f_q(ind)%rval4d(:,:,1)=0
135    ENDDO
136
137
138    CALL deallocate_field(f_ts)
139    CALL deallocate_field(f_z)
140    CALL deallocate_field(f_ulon_reg)
141    CALL deallocate_field(f_ulat_reg)
142    CALL deallocate_field(f_temp_reg)
143    CALL deallocate_field(f_q_reg)
144   
145    CALL deallocate_field(f_q1)
146    CALL deallocate_field(f_qsat)
147    CALL deallocate_field(f_p)
148    CALL deallocate_field(f_temp)
149    CALL deallocate_field(f_ulon)
150    CALL deallocate_field(f_ulat)   
151 
152  END SUBROUTINE etat0
153
154END MODULE etat0_database_mod
Note: See TracBrowser for help on using the repository browser.