Changeset 17 for codes/icosagcm/trunk
- Timestamp:
- 07/16/12 10:24:35 (12 years ago)
- Location:
- codes/icosagcm/trunk/src
- Files:
-
- 9 added
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
codes/icosagcm/trunk/src/caldyn_gcm.f90
r15 r17 4 4 USE transfert_mod 5 5 6 PRIVATE 6 7 TYPE(t_field),POINTER :: f_out(:) 7 8 REAL(rstd),POINTER :: out(:,:) … … 12 13 13 14 INTEGER :: itau_out 14 15 16 PUBLIC init_caldyn, caldyn 17 15 18 CONTAINS 16 19 … … 19 22 IMPLICIT NONE 20 23 REAL(rstd),INTENT(IN) :: dt 21 REAL(rstd) :: write_period 24 INTEGER :: write_period 25 22 26 CALL allocate_caldyn 23 24 27 CALL getin('write_period',write_period) 25 28 26 29 itau_out=INT(write_period/dt) 30 31 CALL allocate_caldyn 27 32 28 33 END SUBROUTINE init_caldyn … … 34 39 USE metric 35 40 IMPLICIT NONE 36 INTEGER :: ind,i,j37 41 38 42 CALL allocate_field(f_out,field_t,type_real,llm) -
codes/icosagcm/trunk/src/disvert.f90
r12 r17 1 1 MODULE disvert_mod 2 2 USE prec 3 REAL(rstd), SAVE, ALLOCATABLE:: ap(:)4 REAL(rstd), SAVE, ALLOCATABLE:: bp(:)5 REAL(rstd), SAVE, ALLOCATABLE:: presnivs(:)3 REAL(rstd), SAVE, POINTER :: ap(:) 4 REAL(rstd), SAVE, POINTER :: bp(:) 5 REAL(rstd), SAVE, POINTER :: presnivs(:) 6 6 7 7 CONTAINS 8 8 9 9 SUBROUTINE init_disvert 10 USE grid_param 10 USE disvert_std_mod, ONLY: ap_std=>ap, bp_std=>bp, presnivs_std=>presnivs, init_disvert_std=>init_disvert 11 USE disvert_ncar_mod, ONLY: ap_ncar=>ap, bp_ncar=>bp, presnivs_ncar=>presnivs, init_disvert_ncar=>init_disvert 12 USE ioipsl 11 13 IMPLICIT NONE 12 13 ALLOCATE(ap(llm+1)) 14 ALLOCATE(bp(llm+1)) 15 ALLOCATE(presnivs(llm)) 14 CHARACTER(LEN=255) :: disvert_type = 'std' 15 16 CALL getin("disvert",disvert_type) 17 18 SELECT CASE (TRIM(disvert_type)) 19 CASE('std') 20 21 CALL init_disvert_std 22 ap=>ap_std 23 bp=>bp_std 24 presnivs=>presnivs_std 25 26 CASE ('ncar') 16 27 17 CALL disvert(ap,bp,presnivs) 28 CALL init_disvert_ncar 29 ap=>ap_ncar 30 bp=>bp_ncar 31 presnivs=>presnivs_ncar 32 33 CASE default 34 PRINT*,'Bad selector for variable disvert : <', TRIM(disvert_type),"> options are <std>, <ncar>" 35 STOP 36 37 END SELECT 18 38 19 39 END SUBROUTINE init_disvert 20 21 22 SUBROUTINE disvert(ap,bp,presnivs)23 USE earth_const24 USE math_const25 USE grid_param26 IMPLICIT NONE27 REAL(rstd),INTENT(OUT) :: ap(:)28 REAL(rstd),INTENT(OUT) :: bp(:)29 REAL(rstd),INTENT(OUT) :: presnivs(:)30 31 REAL(rstd) :: dsig(llm)32 REAL(rstd) :: sig(llm+1)33 REAL(rstd) :: snorm34 INTEGER :: l35 36 snorm = 0.37 DO l = 1, llm38 dsig(l) = 1.0 + 7.0 * SIN( Pi*(l-0.5)/(llm+1) )**239 snorm = snorm + dsig(l)40 ENDDO41 42 DO l = 1, llm43 dsig(l) = dsig(l)/snorm44 ENDDO45 46 sig(llm+1) = 0.47 DO l = llm, 1, -148 sig(l) = sig(l+1) + dsig(l)49 ENDDO50 51 bp(llm+1) = 0.52 DO l = 1, llm53 bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )54 ap(l) = pa * ( sig(l) - bp(l) )55 ENDDO56 bp(1)=1.57 ap(1)=0.58 ap(llm+1) = pa * ( sig(llm+1) - bp(llm+1) )59 60 PRINT*,'ap',ap61 PRINT*,'bp',bp62 63 PRINT*, 'Niveaux de pressions approximatifs aux centres des'64 PRINT*, 'couches calcules pour une pression de surface =', preff65 PRINT*, 'et altitudes equivalentes pour une hauteur d echelle de'66 PRINT*, '8km'67 68 DO l = 1, llm69 presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )70 71 PRINT*, 'PRESNIVS(',l,')=',presnivs(l),' Z ~ ',log(preff/presnivs(l))*8., &72 ' DZ ~ ',8.*log((ap(l)+bp(l)*preff)/ max(ap(l+1)+bp(l+1)*preff,1.e-10))73 ENDDO74 75 END SUBROUTINE disvert76 40 77 41 END MODULE disvert_mod -
codes/icosagcm/trunk/src/etat0.f90
r12 r17 1 1 MODULE etat0_mod 2 2 3 USE etat0_academic_mod 4 USE etat0_jablonowsky06_mod 5 USE etat0_williamson_mod 3 4 CONTAINS 5 6 SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 7 USE field_mod 8 USE domain_mod 9 USE domain_mod 10 USE dimensions 11 USE grid_param 12 USE geometry 13 USE etat0_jablonowsky06_mod, ONLY : etat0_jablonowsky06=>etat0 14 USE etat0_academic_mod, ONLY : etat0_academic=>etat0 15 USE etat0_ncar_mod, ONLY : etat0_ncar=>etat0 16 USE ioipsl 17 IMPLICIT NONE 18 TYPE(t_field),POINTER :: f_ps(:) 19 TYPE(t_field),POINTER :: f_phis(:) 20 TYPE(t_field),POINTER :: f_theta_rhodz(:) 21 TYPE(t_field),POINTER :: f_u(:) 22 TYPE(t_field),POINTER :: f_q(:) 23 24 CHARACTER(len=255) :: etat0_type 25 26 etat0_type='jablonowsky06' 27 CALL getin("etat0",etat0_type) 28 29 SELECT CASE (TRIM(etat0_type)) 30 CASE ('jablonowsky06') 31 CALL etat0_jablonowsky06(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 32 CASE ('academic') 33 CALL etat0_academic(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 34 CASE ('ncar') 35 CALL etat0_ncar(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 36 CASE DEFAULT 37 PRINT*, 'Bad selector for varaiable etat0 <',etat0_type,'> options are <jablonowsky06>, <academic>, <ncar> ' 38 STOP 39 END SELECT 40 41 END SUBROUTINE etat0 42 6 43 END MODULE etat0_mod -
codes/icosagcm/trunk/src/etat0_academic.f90
r13 r17 19 19 TYPE(t_field),POINTER :: f_theta_rhodz(:) 20 20 TYPE(t_field),POINTER :: f_u(:) 21 TYPE(t_field),POINTER :: f_q(:) 21 22 TYPE(t_field),POINTER :: f_Ki(:) 22 23 TYPE(t_field),POINTER :: f_temp(:) … … 34 35 CALL allocate_field(f_temp,field_t,type_real) 35 36 36 CALL etat0 _academic(f_ps,f_phis,f_theta_rhodz,f_u)37 CALL etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 37 38 38 39 CALL kinetic(f_u,f_Ki) … … 46 47 47 48 48 SUBROUTINE etat0 _academic(f_ps,f_phis,f_theta_rhodz,f_u)49 SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 49 50 USE field_mod 50 51 USE domain_mod … … 58 59 TYPE(t_field),POINTER :: f_theta_rhodz(:) 59 60 TYPE(t_field),POINTER :: f_u(:) 61 TYPE(t_field),POINTER :: f_q(:) 60 62 61 63 REAL(rstd),POINTER :: ps(:) … … 75 77 ENDDO 76 78 77 END SUBROUTINE etat0 _academic79 END SUBROUTINE etat0 78 80 79 81 SUBROUTINE compute_etat0_academic(ps, phis, theta_rhodz, u) -
codes/icosagcm/trunk/src/etat0_jablonowsky06.f90
r15 r17 12 12 REAL(rstd),PARAMETER :: Gamma=0.005 13 13 REAL(rstd),PARAMETER :: up0=1 14 PUBLIC test_etat0_jablonowsky06, etat0 _jablonowsky06, compute_etat0_jablonowsky0614 PUBLIC test_etat0_jablonowsky06, etat0, compute_etat0_jablonowsky06 15 15 CONTAINS 16 16 … … 39 39 TYPE(t_field),POINTER :: f_phi(:) 40 40 TYPE(t_field),POINTER :: f_vort(:) 41 TYPE(t_field),POINTER :: f_q(:) 41 42 42 43 REAL(rstd),POINTER :: Ki(:,:) … … 57 58 CALL allocate_field(f_vort,field_z,type_real,llm) 58 59 59 CALL etat0 _jablonowsky06(f_ps,f_phis,f_theta_rhodz,f_u)60 CALL etat0(f_ps,f_phis,f_theta_rhodz,f_u,f_q) 60 61 61 62 CALL kinetic(f_u,f_Ki) … … 77 78 78 79 79 SUBROUTINE etat0 _jablonowsky06(f_ps,f_phis,f_theta_rhodz,f_u)80 SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 80 81 USE field_mod 81 82 USE domain_mod … … 89 90 TYPE(t_field),POINTER :: f_theta_rhodz(:) 90 91 TYPE(t_field),POINTER :: f_u(:) 92 TYPE(t_field),POINTER :: f_q(:) 91 93 92 94 REAL(rstd),POINTER :: ps(:) … … 94 96 REAL(rstd),POINTER :: theta_rhodz(:,:) 95 97 REAL(rstd),POINTER :: u(:,:) 98 REAL(rstd),POINTER :: q(:,:,:) 96 99 INTEGER :: ind 97 100 … … 103 106 theta_rhodz=f_theta_rhodz(ind) 104 107 u=f_u(ind) 108 q=f_q(ind) 109 q=0 105 110 CALL compute_etat0_jablonowsky06(ps, phis, theta_rhodz, u) 106 111 ENDDO 107 112 108 END SUBROUTINE etat0 _jablonowsky06113 END SUBROUTINE etat0 109 114 110 115 SUBROUTINE compute_etat0_jablonowsky06(ps, phis, theta_rhodz, u) -
codes/icosagcm/trunk/src/geometry.f90
r15 r17 115 115 USE transfert_mod 116 116 USE vector 117 USE ioipsl 117 118 IMPLICIT NONE 118 INTEGER ,PARAMETER :: nb_it=3000119 INTEGER :: nb_it=0 119 120 TYPE(t_domain),POINTER :: d 120 121 INTEGER :: ind,it,i,j,n,k … … 124 125 REAL(rstd) :: sum 125 126 LOGICAL :: check 127 128 129 CALL getin('optim_it',nb_it) 126 130 127 131 DO ind=1,ndomain -
codes/icosagcm/trunk/src/grid_param.f90
r15 r17 4 4 INTEGER,PARAMETER :: nb_face=10 5 5 INTEGER :: llm=19 6 INTEGER :: nqtot 6 7 7 8 CONTAINS … … 11 12 IMPLICIT NONE 12 13 CALL getin('nbp',iim_glo) 13 jjm_glo= 4014 jjm_glo=iim_glo 14 15 CALL getin('llm',llm) 16 17 nqtot=1 18 CALL getin('nqtot',nqtot) 15 19 16 20 END SUBROUTINE init_grid_param -
codes/icosagcm/trunk/src/timeloop_gcm.f90
r15 r17 3 3 USE transfert_mod 4 4 USE etat0_mod 5 6 INTEGER,PARAMETER :: euler=1, leapfrog=2, leapfrog_matsuno=3, adam_bashforth=47 5 8 6 CONTAINS … … 18 16 USE dissip_gcm_mod 19 17 USE ioipsl 20 USE caldyn_ gcm_mod18 USE caldyn_mod 21 19 USE theta2theta_rhodz_mod 22 20 USE etat0_mod 21 USE guided_mod 22 USE advect_tracer_mod 23 23 24 IMPLICIT NONE 24 25 TYPE(t_field),POINTER :: f_phis(:) 25 26 TYPE(t_field),POINTER :: f_theta(:) 27 TYPE(t_field),POINTER :: f_q(:) 26 28 TYPE(t_field),POINTER :: f_dtheta(:) 27 29 TYPE(t_field),POINTER :: f_ps(:),f_psm1(:), f_psm2(:) … … 33 35 34 36 REAL(rstd),POINTER :: phis(:) 37 REAL(rstd),POINTER :: q(:,:,:) 35 38 REAL(rstd),POINTER :: ps(:) ,psm1(:), psm2(:) 36 39 REAL(rstd),POINTER :: u(:,:) , um1(:,:), um2(:,:) … … 42 45 INTEGER :: ind 43 46 INTEGER :: it,i,j,n 44 INTEGER:: scheme47 CHARACTER(len=255) :: scheme 45 48 INTEGER :: matsuno_period 46 49 INTEGER :: itaumax 47 50 INTEGER :: write_period 51 INTEGER :: itau_out 48 52 49 53 dt=90. … … 52 56 itaumax=100 53 57 CALL getin('itaumax',itaumax) 54 55 scheme=leapfrog_matsuno 58 59 write_period=0 60 CALL getin('write_period',write_period) 61 itau_out=INT(write_period/dt) 62 63 scheme='adam_bashforth' 56 64 CALL getin('scheme',scheme) 57 65 58 66 matsuno_period=5 59 67 CALL getin('matsuno_period',matsuno_period) 60 IF ( scheme==leapfrog) matsuno_period=itaumax+168 IF (TRIM(scheme)=='leapfrog') matsuno_period=itaumax+1 61 69 62 70 CALL allocate_field(f_phis,field_t,type_real) … … 79 87 CALL allocate_field(f_dtheta,field_t,type_real,llm) 80 88 89 CALL allocate_field(f_q,field_t,type_real,llm,nqtot) 90 81 91 CALL allocate_field(f_theta_rhodz,field_t,type_real,llm) 82 92 CALL allocate_field(f_theta_rhodzm1,field_t,type_real,llm) … … 88 98 CALL init_dissip(dt) 89 99 CALL init_caldyn(dt) 90 91 ! CALL etat0_academic(f_ps,f_phis,f_theta_rhodz,f_u)92 CALL etat0_jablonowsky06(f_ps,f_phis,f_theta_rhodz,f_u)93 ! CALL test_etat0_jablonowsky06 100 CALL init_guided(dt) 101 CALL init_advect_tracer(dt) 102 103 CALL etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 94 104 95 105 DO it=0,itaumax 96 106 PRINT *,"It No :",It 97 107 108 CALL guided(it,f_ps,f_theta_rhodz,f_u,f_q) 98 109 CALL caldyn(it,f_phis,f_ps,f_theta_rhodz,f_u, f_dps, f_dtheta_rhodz, f_du) 99 100 IF (scheme==Euler) THEN 101 CALL euler_scheme 102 ELSE IF (scheme==leapfrog) THEN 103 CALL leapfrog_scheme 104 ELSE IF (scheme==leapfrog_matsuno) THEN 105 CALL leapfrog_matsuno_scheme 106 ELSE IF (scheme==adam_bashforth) THEN 107 CALL dissip(f_u,f_du,f_ps,f_theta_rhodz,f_dtheta_rhodz) 108 CALL adam_bashforth_scheme 110 CALL advect_tracer(f_ps,f_u,f_q) 111 112 SELECT CASE (TRIM(scheme)) 113 CASE('euler') 114 CALL euler_scheme 115 116 CASE ('leapfrog') 117 CALL leapfrog_scheme 118 119 CASE ('leapfrog_matsuno') 120 CALL leapfrog_matsuno_scheme 121 122 CASE ('adam_bashforth') 123 CALL dissip(f_u,f_du,f_ps,f_theta_rhodz,f_dtheta_rhodz) 124 CALL adam_bashforth_scheme 125 126 CASE default 127 PRINT*,'Bad selector for variable scheme : <', TRIM(scheme),"> options are <euler>, <leapfrog>, <leapfrog_matsuno>, <adam_bashforth>" 128 STOP 129 130 END SELECT 131 132 133 IF ( itau_out>0 .AND. MOD(it,itau_out)==0) THEN 134 CALL writefield("q",f_q) 135 CALL writefield("ps",f_ps) 109 136 ENDIF 110 137 -
codes/icosagcm/trunk/src/timeloop_sw.f90
r15 r17 2 2 USE genmod 3 3 USE transfert_mod 4 USE etat0_ mod4 USE etat0_williamson_mod 5 5 6 6 INTEGER,PARAMETER :: euler=1, leapfrog=2, leapfrog_matsuno=3, adam_bashforth=4 -
codes/icosagcm/trunk/src/write_field.f90
r15 r17 3 3 implicit none 4 4 5 TYPE ncvar 6 INTEGER :: size 7 INTEGER,POINTER :: nc_id(:) 8 END TYPE ncvar 9 5 10 integer, parameter :: MaxWriteField = 1000 6 11 integer, dimension(MaxWriteField),save :: FieldId 7 integer, dimension(MaxWriteField),save :: FieldVarId12 TYPE(ncvar), dimension(MaxWriteField),save :: FieldVarId 8 13 integer, dimension(MaxWriteField),save :: FieldIndex 9 14 character(len=255), dimension(MaxWriteField) :: FieldName … … 87 92 TYPE(t_domain),POINTER :: d 88 93 INTEGER :: Index 89 INTEGER :: ind,i,j,k,n,ncell 94 INTEGER :: ind,i,j,k,n,ncell,q 90 95 INTEGER :: iie,jje,iin,jjn 91 96 INTEGER :: status … … 149 154 ENDDO 150 155 ENDDO 151 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index) ,Field_val2d,start=(/ ncell,FieldIndex(Index) /),count=(/n,1 /))156 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(1),Field_val2d,start=(/ ncell,FieldIndex(Index) /),count=(/n,1 /)) 152 157 DEALLOCATE(field_val2d) 153 158 ELSE IF (field(ind)%ndim==3) THEN … … 163 168 ENDDO 164 169 ENDDO 165 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index) ,Field_val3d,start=(/ ncell,1,FieldIndex(Index) /), &170 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(1),Field_val3d,start=(/ ncell,1,FieldIndex(Index) /), & 166 171 count=(/n,size(field(1)%rval3d,2),1 /)) 167 172 DEALLOCATE(field_val3d) 168 173 ELSE IF (field(1)%ndim==4) THEN 169 ALLOCATE(Field_val4d(n,size(field(ind)%rval4d,2),size(field(ind)%rval4d,3))) 170 n=0 171 DO j=d%jj_begin-halo_size,d%jj_end+halo_size 172 DO i=d%ii_begin-halo_size,d%ii_end+halo_size 173 k=d%iim*(j-1)+i 174 IF (d%own(i,j) .OR. single) THEN 175 n=n+1 176 Field_val4d(n,:,:)=field(ind)%rval4d(k,:,:) 177 ENDIF 178 ENDDO 179 ENDDO 180 181 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index),Field_val4d,start=(/ ncell,1,1,FieldIndex(Index) /), & 182 count=(/n,size(field(1)%rval4d,2),size(field(1)%rval4d,3),1 /)) 183 DEALLOCATE(field_val4d) 174 175 DO q=1,FieldVarId(index)%size 176 177 ALLOCATE(Field_val3d(n,size(field(ind)%rval4d,2))) 178 n=0 179 DO j=d%jj_begin-halo_size,d%jj_end+halo_size 180 DO i=d%ii_begin-halo_size,d%ii_end+halo_size 181 k=d%iim*(j-1)+i 182 IF (d%own(i,j) .OR. single) THEN 183 n=n+1 184 Field_val3d(n,:)=field(ind)%rval4d(k,:,q) 185 ENDIF 186 ENDDO 187 ENDDO 188 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(q),Field_val3d,start=(/ ncell,1,FieldIndex(Index) /), & 189 count=(/n,size(field(1)%rval4d,2),1 /)) 190 DEALLOCATE(field_val3d) 191 ENDDO 184 192 ENDIF 185 193 … … 230 238 ENDDO 231 239 232 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index) ,Field_val2d,start=(/ ncell,FieldIndex(Index) /),count=(/n,1 /))240 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(1),Field_val2d,start=(/ ncell,FieldIndex(Index) /),count=(/n,1 /)) 233 241 DEALLOCATE(field_val2d) 234 242 … … 251 259 ENDDO 252 260 ENDDO 253 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index) ,Field_val3d,start=(/ ncell,1,FieldIndex(Index) /), &261 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(1),Field_val3d,start=(/ ncell,1,FieldIndex(Index) /), & 254 262 count=(/n,size(field(1)%rval3d,2),1 /)) 255 263 DEALLOCATE(field_val3d) 256 264 ELSE IF (field(1)%ndim==4) THEN 257 ALLOCATE(Field_val4d(n,size(field(ind)%rval4d,2),size(field(ind)%rval4d,3))) 258 n=0 259 DO j=jj_begin+1,jj_end 260 DO i=ii_begin,ii_end-1 261 n=n+1 262 k=iim*(j-1)+i 263 Field_val4d(n,:,:)=field(ind)%rval4d(k+z_down,:,:) 264 ENDDO 265 ENDDO 266 267 DO j=jj_begin,jj_end-1 268 DO i=ii_begin+1,ii_end 269 n=n+1 270 k=iim*(j-1)+i 271 Field_val4d(n,:,:)=field(ind)%rval4d(k+z_up,:,:) 272 ENDDO 273 ENDDO 274 275 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index),Field_val4d,start=(/ ncell,1,1,FieldIndex(Index) /), & 276 count=(/n,size(field(1)%rval4d,2),size(field(1)%rval4d,3),1 /)) 277 DEALLOCATE(field_val4d) 265 266 DO q=1,FieldVarId(index)%size 267 ALLOCATE(Field_val3d(n,size(field(ind)%rval4d,2))) 268 n=0 269 DO j=jj_begin+1,jj_end 270 DO i=ii_begin,ii_end-1 271 n=n+1 272 k=iim*(j-1)+i 273 Field_val3d(n,:)=field(ind)%rval4d(k+z_down,:,q) 274 ENDDO 275 ENDDO 276 277 DO j=jj_begin,jj_end-1 278 DO i=ii_begin+1,ii_end 279 n=n+1 280 k=iim*(j-1)+i 281 Field_val3d(n,:)=field(ind)%rval4d(k+z_up,:,q) 282 ENDDO 283 ENDDO 284 285 status=NF90_PUT_VAR(FieldId(Index),FieldVarId(index)%nc_id(q),Field_val3d,start=(/ ncell,1,1,FieldIndex(Index) /), & 286 count=(/n,size(field(1)%rval4d,2),1 /)) 287 DEALLOCATE(field_val3d) 288 ENDDO 278 289 ENDIF 279 290 … … 307 318 INTEGER :: dim3id,dim4id 308 319 INTEGER :: status 309 INTEGER :: ind,i,j,k,n 320 INTEGER :: ind,i,j,k,n,q 310 321 INTEGER :: iie,jje,iin,jjn 311 322 INTEGER :: ind_b,ind_e … … 351 362 status = NF90_DEF_DIM(ncid,'nvert',nvert,nvertid) 352 363 353 IF (Field(ind_b)%ndim==3) THEN 364 IF (Field(ind_b)%ndim==2) THEN 365 FieldVarId(NbField)%size=1 366 ALLOCATE(FieldVarId(NbField)%nc_id(1)) 367 ELSE IF (Field(ind_b)%ndim==3) THEN 368 FieldVarId(NbField)%size=1 369 ALLOCATE(FieldVarId(NbField)%nc_id(1)) 354 370 status = NF90_DEF_DIM(ncid,'Z',size(field(ind_b)%rval3d,2),dim3id) 355 371 ELSE IF (Field(1)%ndim==4) THEN 372 FieldVarId(NbField)%size=size(field(ind_b)%rval4d,3) 373 ALLOCATE(FieldVarId(NbField)%nc_id(FieldVarId(NbField)%size)) 356 374 status = NF90_DEF_DIM(ncid,'Z',size(field(ind_b)%rval4d,2),dim3id) 357 status = NF90_DEF_DIM(ncid,'Q',size(field(ind_b)%rval4d,3),dim4id)375 ! status = NF90_DEF_DIM(ncid,'Q',size(field(ind_b)%rval4d,3),dim4id) 358 376 ENDIF 359 377 … … 372 390 373 391 IF (Field(ind_b)%ndim==2) THEN 374 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,timeId /),FieldVarId(NbField)) 392 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,timeId /),FieldVarId(NbField)%nc_id(1)) 393 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(1),"coordinates","lon lat") 375 394 ELSE IF (Field(ind_b)%ndim==3) THEN 376 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)) 395 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)%nc_id(1)) 396 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(1),"coordinates","lon lat") 377 397 ELSE IF (Field(ind_b)%ndim==4) THEN 378 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,dim4id,timeId /),FieldVarId(NbField)) 398 DO i=1,FieldVarId(NbField)%size 399 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name))//int2str(i),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)%nc_id(i)) 400 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(i),"coordinates","lon lat") 401 ENDDO 379 402 ENDIF 380 403 381 status = NF90_PUT_ATT(ncid,FieldVarId(NbField),"coordinates","lon lat") 382 404 383 405 status = NF90_ENDDEF(ncid) 384 406 … … 445 467 status = NF90_DEF_DIM(ncid,'nvert',nvert,nvertid) 446 468 447 IF (Field(ind_b)%ndim==3) THEN 469 IF (Field(ind_b)%ndim==2) THEN 470 FieldVarId(NbField)%size=1 471 ALLOCATE(FieldVarId(NbField)%nc_id(1)) 472 ELSE IF (Field(ind_b)%ndim==3) THEN 473 FieldVarId(NbField)%size=1 474 ALLOCATE(FieldVarId(NbField)%nc_id(1)) 448 475 status = NF90_DEF_DIM(ncid,'Z',size(field(ind_b)%rval3d,2),dim3id) 449 476 ELSE IF (Field(1)%ndim==4) THEN 477 FieldVarId(NbField)%size=size(field(ind_b)%rval4d,3) 478 ALLOCATE(FieldVarId(NbField)%nc_id(FieldVarId(NbField)%size)) 450 479 status = NF90_DEF_DIM(ncid,'Z',size(field(ind_b)%rval4d,2),dim3id) 451 status = NF90_DEF_DIM(ncid,'Q',size(field(ind_b)%rval4d,3),dim4id)452 480 ENDIF 481 482 453 483 454 484 status = NF90_DEF_DIM(ncid,'time_counter',NF90_UNLIMITED,timeId) … … 465 495 status = NF90_DEF_VAR(ncid,'bounds_lat',NF90_DOUBLE,(/ nvertid,ncellId /),bounds_latId) 466 496 497 467 498 IF (Field(ind_b)%ndim==2) THEN 468 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,timeId /),FieldVarId(NbField)) 499 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,timeId /),FieldVarId(NbField)%nc_id(1)) 500 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(1),"coordinates","lon lat") 469 501 ELSE IF (Field(ind_b)%ndim==3) THEN 470 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)) 502 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)%nc_id(1)) 503 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(1),"coordinates","lon lat") 471 504 ELSE IF (Field(ind_b)%ndim==4) THEN 472 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)),NF90_DOUBLE,(/ ncellId,dim3id,dim4id,timeId /),FieldVarId(NbField)) 505 DO q=1,FieldVarId(NbField)%size 506 status = NF90_DEF_VAR(ncid,TRIM(ADJUSTL(name)//int2str(q)),NF90_DOUBLE,(/ ncellId,dim3id,timeId /),FieldVarId(NbField)%nc_id(q)) 507 status = NF90_PUT_ATT(ncid,FieldVarId(NbField)%nc_id(q),"coordinates","lon lat") 508 ENDDO 473 509 ENDIF 474 475 status = NF90_PUT_ATT(ncid,FieldVarId(NbField),"coordinates","lon lat")476 510 477 511 status = NF90_ENDDEF(ncid)
Note: See TracChangeset
for help on using the changeset viewer.