- Timestamp:
- 08/05/14 15:56:49 (10 years ago)
- Location:
- codes/icosagcm/trunk/src
- Files:
-
- 3 added
- 18 edited
Legend:
- Unmodified
- Added
- Removed
-
codes/icosagcm/trunk/src/caldyn_gcm.f90
r202 r266 300 300 ! f_buf_i, f_buf_v, f_buf_u3d, f_buf_ulon, f_buf_ulat, f_buf_s, f_buf_p) 301 301 CALL un2ulonlat(f_u, f_buf_ulon, f_buf_ulat) 302 CALL writefield("ulon",f_buf_ulon)303 CALL writefield("ulat",f_buf_ulat)302 CALL output_field("ulon",f_buf_ulon) 303 CALL output_field("ulat",f_buf_ulat) 304 304 305 305 CALL output_field("ps",f_ps) -
codes/icosagcm/trunk/src/check_conserve.f90
r198 r266 71 71 IF (is_mpi_root) THEN 72 72 !$OMP MASTER 73 IF ( it == 0 ) Then73 IF ( it == itau0 ) Then 74 74 ztot0 = ztot 75 75 mtot0 = mtot -
codes/icosagcm/trunk/src/disvert_apbp.f90
r210 r266 57 57 ENDIF 58 58 ENDDO 59 60 CLOSE(unit) 59 61 !$OMP END MASTER 60 62 IF (omp_in_parallel()) THEN … … 74 76 WRITE(*,*) "bp()=",bp 75 77 WRITE(*,*) "Approximative mid-layer pressure, assuming a surface pressure preff=",preff," Pa" 76 WRITE(*,*) "and approximative mid-layer height, assuming an atmospheric scale height of ",scale height/1000," (km)"78 WRITE(*,*) "and approximative mid-layer height, assuming an atmospheric scale height of ",scale_height/1000," (km)" 77 79 DO l=1,llm 78 WRITE(*,*) 'PRESNIVS(',l,')=',presnivs(l),' Z ~ ',log(preff/presnivs(l))*scale height/1000, &79 ' DZ ~ ',scale height/1000*log((ap(l)+bp(l)*preff)/ max(ap(l+1)+bp(l+1)*preff,1.e-10))80 WRITE(*,*) 'PRESNIVS(',l,')=',presnivs(l),' Z ~ ',log(preff/presnivs(l))*scale_height/1000, & 81 ' DZ ~ ',scale_height/1000*log((ap(l)+bp(l)*preff)/ max(ap(l+1)+bp(l+1)*preff,1.e-10)) 80 82 ENDDO 81 83 !$OMP END MASTER -
codes/icosagcm/trunk/src/disvert_std.f90
r208 r266 70 70 WRITE(*,*) "bp()=",bp 71 71 WRITE(*,*) "Approximative mid-layer pressure, assuming a surface pressure preff=",preff," Pa" 72 WRITE(*,*) "and approximative mid-layer height, assuming an atmospheric scale height of ",scale height/1000," (km)"72 WRITE(*,*) "and approximative mid-layer height, assuming an atmospheric scale height of ",scale_height/1000," (km)" 73 73 DO l=1,llm 74 WRITE(*,*) 'PRESNIVS(',l,')=',presnivs(l),' Z ~ ',log(preff/presnivs(l))*scale height/1000, &75 ' DZ ~ ',scale height/1000*log((ap(l)+bp(l)*preff)/ max(ap(l+1)+bp(l+1)*preff,1.e-10))74 WRITE(*,*) 'PRESNIVS(',l,')=',presnivs(l),' Z ~ ',log(preff/presnivs(l))*scale_height/1000, & 75 ' DZ ~ ',scale_height/1000*log((ap(l)+bp(l)*preff)/ max(ap(l+1)+bp(l+1)*preff,1.e-10)) 76 76 ENDDO 77 77 !$OMP END MASTER -
codes/icosagcm/trunk/src/domain.f90
r186 r266 17 17 INTEGER :: jj_end_glo 18 18 INTEGER,POINTER :: assign_domain(:,:) 19 INTEGER,POINTER :: assign_cell_glo(:,:) 19 20 INTEGER,POINTER :: assign_i(:,:) 20 21 INTEGER,POINTER :: assign_j(:,:) … … 142 143 d%face=nf 143 144 ALLOCATE(d%assign_domain(d%iim,d%jjm)) 145 ALLOCATE(d%assign_cell_glo(d%iim,d%jjm)) 144 146 ALLOCATE(d%assign_i(d%iim,d%jjm)) 145 147 ALLOCATE(d%assign_j(d%iim,d%jjm)) … … 183 185 d2%jj_end_glo = d1%jj_end_glo 184 186 d2%assign_domain => d1%assign_domain 187 d2%assign_cell_glo => d1%assign_cell_glo 185 188 d2%assign_i => d1%assign_i 186 189 d2%assign_j => d1%assign_j … … 268 271 jj=d%jj_begin_glo-d%jj_begin+j 269 272 ind=vertex_glo(ii,jj,nf)%ind 273 d%assign_cell_glo(i,j) = ind 270 274 d%assign_domain(i,j)=cell_glo(ind)%assign_domain 271 275 d%assign_i(i,j)=cell_glo(ind)%assign_i -
codes/icosagcm/trunk/src/earth_const.f90
r208 r266 11 11 REAL(rstd),SAVE :: preff=101325. 12 12 REAL(rstd),SAVE :: pa=50000. 13 REAL(rstd),SAVE :: scale height=8000. ! atmospheric scale height (m)13 REAL(rstd),SAVE :: scale_height=8000. ! atmospheric scale height (m) 14 14 REAL(rstd),SAVE :: scale_factor=1. 15 REAL(rstd),SAVE :: gas_constant = 8.3144621 16 REAL(rstd),SAVE :: mu ! molar mass of the atmosphere 15 17 16 18 LOGICAL, SAVE :: boussinesq … … 30 32 CALL getin("cpp",cpp) 31 33 CALL getin("preff",preff) 32 CALL getin("scale height",scaleheight)34 CALL getin("scale_height",scale_height) 33 35 36 mu=kappa/cpp 34 37 boussinesq=.FALSE. 35 38 CALL getin("boussinesq",boussinesq) -
codes/icosagcm/trunk/src/etat0.f90
r204 r266 27 27 USE dynetat0_gcm_mod, ONLY : dynetat0_start=>etat0 28 28 USE dynetat0_hz_mod, ONLY : dynetat0_hz=>etat0 29 USE etat0_start_file_mod, ONLY : etat0_start_file=>etat0 29 30 30 31 IMPLICIT NONE … … 66 67 CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q) 67 68 !------------------- Old interface -------------------- 69 CASE ('start_file') 70 CALL etat0_start_file(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 68 71 CASE ('academic') 69 72 CALL etat0_academic(f_ps,f_phis,f_theta_rhodz,f_u, f_q) -
codes/icosagcm/trunk/src/field.f90
r186 r266 116 116 END SUBROUTINE allocate_field 117 117 118 SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2 )118 SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name) 119 119 USE domain_mod 120 120 IMPLICIT NONE … … 123 123 INTEGER,INTENT(IN) :: data_type 124 124 INTEGER,OPTIONAL :: dim1,dim2 125 CHARACTER(*), OPTIONAL :: name 125 126 INTEGER :: ind 126 127 INTEGER :: ii_size,jj_size … … 141 142 ENDIF 142 143 144 IF(PRESENT(name)) THEN 145 field(ind)%name = name 146 ELSE 147 field(ind)%name = '(undefined)' 148 END IF 143 149 144 150 field(ind)%data_type=data_type … … 180 186 INTEGER :: ind 181 187 188 !$OMP BARRIER 182 189 DO ind=1,ndomain 190 IF (.NOT. assigned_domain(ind)) CYCLE 183 191 184 192 data_type=field(ind)%data_type … … 199 207 200 208 ENDDO 209 !$OMP BARRIER 210 !$OMP MASTER 201 211 DEALLOCATE(field) 212 !$OMP END MASTER 213 !$OMP BARRIER 202 214 203 215 END SUBROUTINE deallocate_field -
codes/icosagcm/trunk/src/geometry.f90
r186 r266 83 83 IMPLICIT NONE 84 84 85 CALL allocate_field(geom%Ai,field_t,type_real )85 CALL allocate_field(geom%Ai,field_t,type_real,name='Ai') 86 86 CALL allocate_field(geom%xyz_i,field_t,type_real,3) 87 87 CALL allocate_field(geom%centroid,field_t,type_real,3) -
codes/icosagcm/trunk/src/mpi_mod.F90
r189 r266 7 7 INTEGER :: MPI_REAL8 8 8 INTEGER :: MPI_INTEGER 9 INTEGER :: MPI_CHARACTER 10 INTEGER :: MPI_LOGICAL 9 11 INTEGER :: MPI_ANY_SOURCE 10 12 INTEGER :: MPI_MAX -
codes/icosagcm/trunk/src/mpipara.F90
r216 r266 9 9 LOGICAL,SAVE :: using_mpi 10 10 LOGICAL,SAVE :: is_mpi_root 11 LOGICAL,SAVE :: is_mpi_master 12 LOGICAL,SAVE :: mpi_master 13 11 14 12 15 INTERFACE allocate_mpi_buffer … … 108 111 ENDIF 109 112 113 mpi_master=0 110 114 IF (mpi_rank==0) THEN 111 115 is_mpi_root=.TRUE. 116 is_mpi_master=.TRUE. 112 117 ELSE 113 118 is_mpi_root=.FALSE. 119 is_mpi_master=.FALSE. 114 120 ENDIF 115 121 … … 118 124 SUBROUTINE finalize_mpipara 119 125 USE mpi_mod 120 IMPLICIT NONE 121 126 #ifdef CPP_USING_XIOS 127 USE xios 128 #endif 129 IMPLICIT NONE 130 131 #ifdef CPP_USING_XIOS 132 CALL xios_finalize 133 #endif 122 134 IF (using_mpi) CALL MPI_FINALIZE(ierr) 123 135 -
codes/icosagcm/trunk/src/physics.f90
r217 r266 51 51 END SUBROUTINE init_physics 52 52 53 SUBROUTINE physics(it, jD_cur,jH_cur,f_phis, f_ps, f_theta_rhodz, f_ue, f_q)53 SUBROUTINE physics(it,f_phis, f_ps, f_theta_rhodz, f_ue, f_q) 54 54 USE icosa 55 55 USE physics_interface_mod … … 58 58 IMPLICIT NONE 59 59 INTEGER, INTENT(IN) :: it 60 REAL(rstd),INTENT(IN)::jD_cur,jH_cur61 60 TYPE(t_field),POINTER :: f_phis(:) 62 61 TYPE(t_field),POINTER :: f_ps(:) -
codes/icosagcm/trunk/src/time.f90
r212 r266 9 9 INTEGER,SAVE :: it 10 10 !$OMP THREADPRIVATE(it) 11 12 INTEGER,SAVE :: itau0=0 13 !$OMP THREADPRIVATE(itau0) 11 14 12 15 REAL(rstd),SAVE :: dt … … 37 40 dt, write_period, itau_out, itau_adv, itau_dissip, itau_physics, itaumax, & 38 41 day_step,ndays,jD_ref,jH_ref,day_ini,day_end,annee_ref,day_ref,an, mois, jour,heure, & 39 calend,time_style 42 calend,time_style,itau0 40 43 41 44 -
codes/icosagcm/trunk/src/timeloop_gcm.f90
r202 r266 21 21 !$OMP THREADPRIVATE(nb_stage, matsuno_period, scheme) 22 22 23 REAL(rstd),SAVE :: jD_cur, jH_cur24 !$OMP THREADPRIVATE(jD_cur, jH_cur)25 REAL(rstd),SAVE :: start_time26 !$OMP THREADPRIVATE(start_time)27 23 CONTAINS 28 24 … … 47 43 CHARACTER(len=255) :: def 48 44 49 !----------------------------------------------------50 ! IF (TRIM(time_style)=='lmd') Then51 52 ! day_step=18053 ! CALL getin('day_step',day_step)54 55 ! ndays=156 ! CALL getin('ndays',ndays)57 58 ! dt = daysec/REAL(day_step)59 ! itaumax = ndays*day_step60 61 ! calend = 'earth_360d'62 ! CALL getin('calend', calend)63 64 ! day_ini = 065 ! CALL getin('day_ini',day_ini)66 67 ! day_end = 068 ! CALL getin('day_end',day_end)69 70 ! annee_ref = 199871 ! CALL getin('annee_ref',annee_ref)72 73 ! start_time = 074 ! CALL getin('start_time',start_time)75 76 !77 ! write_period=078 ! CALL getin('write_period',write_period)79 !80 ! write_period=write_period/scale_factor81 ! itau_out=FLOOR(write_period/dt)82 !83 ! PRINT *, 'Output frequency (scaled) set to ',write_period, ' : itau_out = ',itau_out84 85 ! mois = 1 ; heure = 0.86 ! call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)87 ! jH_ref = jD_ref - int(jD_ref)88 ! jD_ref = int(jD_ref)89 !90 ! CALL ioconf_startdate(INT(jD_ref),jH_ref)91 ! write(*,*)'annee_ref, mois, day_ref, heure, jD_ref'92 ! write(*,*)annee_ref, mois, day_ref, heure, jD_ref93 ! write(*,*)"ndays,day_step,itaumax,dt======>"94 ! write(*,*)ndays,day_step,itaumax,dt95 ! call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)96 ! write(*,*)'jD_ref+jH_ref,an, mois, jour, heure'97 ! write(*,*)jD_ref+jH_ref,an, mois, jour, heure98 ! day_end = day_ini + ndays99 ! END IF100 !----------------------------------------------------101 45 102 46 IF (xios_output) itau_out=1 … … 117 61 CALL allocate_field(f_theta_rhodzm1,field_t,type_real,llm,name='theta_rhodzm1') 118 62 ! Tracers 119 CALL allocate_field(f_q,field_t,type_real,llm,nqtot )63 CALL allocate_field(f_q,field_t,type_real,llm,nqtot,'q') 120 64 CALL allocate_field(f_rhodz,field_t,type_real,llm,name='rhodz') 121 65 ! Mass fluxes … … 212 156 USE xios_mod 213 157 USE output_field_mod 158 USE write_etat0_mod 214 159 IMPLICIT NONE 215 160 REAL(rstd),POINTER :: q(:,:,:) … … 227 172 INTEGER :: stop_clock 228 173 INTEGER :: rate_clock 174 175 176 ! CALL write_etat0(f_ps, f_phis,f_theta_rhodz,f_u,f_q) 177 ! CALL read_start(f_ps,f_mass,f_phis,f_theta_rhodz,f_u,f_q) 178 ! CALL write_restart(f_ps,f_mass,f_phis,f_theta_rhodz,f_u,f_q) 229 179 230 180 CALL caldyn_BC(f_phis, f_wflux) ! set constant values in first/last interfaces … … 248 198 !$OMP END MASTER 249 199 200 CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,itau0) 201 250 202 CALL trace_on 251 203 252 DO it= 0,itaumax204 DO it=itau0+1,itau0+itaumax 253 205 254 206 IF (xios_output) CALL xios_update_calendar(it) 255 IF ( MOD(it,itau_sync)==0) THEN207 IF (it==itau0+1 .OR. MOD(it,itau_sync)==0) THEN 256 208 CALL send_message(f_ps,req_ps0) 257 209 CALL wait_message(req_ps0) … … 299 251 END DO 300 252 301 IF (MOD(it +1,itau_dissip)==0) THEN253 IF (MOD(it,itau_dissip)==0) THEN 302 254 ! CALL send_message(f_ps,req_ps) 303 255 ! CALL wait_message(req_ps) … … 320 272 END IF 321 273 322 IF(MOD(it +1,itau_adv)==0) THEN274 IF(MOD(it,itau_adv)==0) THEN 323 275 324 276 CALL advect_tracer(f_hfluxt,f_wfluxt,f_u, f_q,f_rhodz) ! update q and rhodz after RK step … … 339 291 340 292 341 342 !---------------------------------------------------- 343 ! jD_cur = jD_ref + day_ini - day_ref + it/day_step 344 ! jH_cur = jH_ref + start_time + mod(it,day_step)/float(day_step) 345 ! jD_cur = jD_cur + int(jH_cur) 346 ! jH_cur = jH_cur - int(jH_cur) 347 CALL physics(it,jD_cur,jH_cur,f_phis, f_ps, f_theta_rhodz, f_u, f_q) 348 349 ENDDO 350 351 CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,it) 293 IF (MOD(it,itau_physics)==0) THEN 294 CALL physics(it,f_phis, f_ps, f_theta_rhodz, f_u, f_q) 295 ENDIF 296 297 ENDDO 298 299 CALL write_etat0(itau0+itaumax,f_ps, f_phis,f_theta_rhodz,f_u,f_q) 300 301 CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,it) 352 302 353 303 !$OMP MASTER 354 355 356 357 358 PRINT *,"Time elapsed : ",(stop_clock-start_clock)*1./rate_clock359 304 CALL SYSTEM_CLOCK(stop_clock) 305 CALL SYSTEM_CLOCK(count_rate=rate_clock) 306 307 IF (mpi_rank==0) THEN 308 PRINT *,"Time elapsed : ",(stop_clock-start_clock)*1./rate_clock 309 ENDIF 360 310 !$OMP END MASTER 361 311 362 312 CONTAINS 363 313 364 314 SUBROUTINE Euler_scheme(with_dps) -
codes/icosagcm/trunk/src/transfert.F90
r151 r266 3 3 #ifdef CPP_USING_MPI 4 4 USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_mpi, req_i1,req_e1_vect, & 5 req_e1_scal, req_i0, req_e0_vect, req_e0_scal, request_add_point, create_request, gather_field, &5 req_e1_scal, req_i0, req_e0_vect, req_e0_scal, request_add_point, create_request, gather_field, scatter_field, & 6 6 t_message,init_message=>init_message_mpi,transfert_message=>transfert_message_mpi, & 7 send_message=>send_message_mpi,test_message=>test_message_mpi,wait_message=>wait_message_mpi,barrier 7 send_message=>send_message_mpi,test_message=>test_message_mpi,wait_message=>wait_message_mpi,barrier, & 8 bcast_mpi 8 9 #else 9 10 USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_seq, req_i1,req_e1_vect, & 10 req_e1_scal,req_i0, req_e0_vect, req_e0_scal, request_add_point, create_request, gather_field, &11 req_e1_scal,req_i0, req_e0_vect, req_e0_scal, request_add_point, create_request, gather_field, scatter_field,& 11 12 t_message,init_message=>init_message_seq,transfert_message=>transfert_message_seq, & 12 send_message=>send_message_seq,test_message=>test_message_seq,wait_message=>wait_message_seq,barrier 13 send_message=>send_message_seq,test_message=>test_message_seq,wait_message=>wait_message_seq,barrier, & 14 bcast_mpi 13 15 #endif 16 17 USE transfert_omp_mod 18 19 INTERFACE bcast 20 MODULE PROCEDURE bcast_c, & 21 bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & 22 bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & 23 bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 24 25 END INTERFACE 26 27 28 CONTAINS 29 30 31 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 32 !! Definition des Broadcast --> 4D !! 33 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 34 35 !! -- Les chaine de charactère -- !! 36 37 SUBROUTINE bcast_c(var) 38 IMPLICIT NONE 39 CHARACTER(LEN=*),INTENT(INOUT) :: Var 40 41 !$OMP MASTER 42 CALL bcast_mpi(Var) 43 !$OMP END MASTER 44 CALL bcast_omp(Var) 45 46 END SUBROUTINE bcast_c 47 48 !! -- Les entiers -- !! 49 50 SUBROUTINE bcast_i(var) 51 IMPLICIT NONE 52 INTEGER,INTENT(INOUT) :: Var 53 !$OMP MASTER 54 CALL bcast_mpi(Var) 55 !$OMP END MASTER 56 CALL bcast_omp(Var) 57 58 END SUBROUTINE bcast_i 59 60 SUBROUTINE bcast_i1(var) 61 IMPLICIT NONE 62 INTEGER,INTENT(INOUT) :: Var(:) 63 64 !$OMP MASTER 65 CALL bcast_mpi(Var) 66 !$OMP END MASTER 67 CALL bcast_omp(Var) 68 69 END SUBROUTINE bcast_i1 70 71 72 SUBROUTINE bcast_i2(var) 73 IMPLICIT NONE 74 INTEGER,INTENT(INOUT) :: Var(:,:) 75 76 !$OMP MASTER 77 CALL bcast_mpi(Var) 78 !$OMP END MASTER 79 CALL bcast_omp(Var) 80 81 END SUBROUTINE bcast_i2 82 83 84 SUBROUTINE bcast_i3(var) 85 IMPLICIT NONE 86 INTEGER,INTENT(INOUT) :: Var(:,:,:) 87 88 !$OMP MASTER 89 CALL bcast_mpi(Var) 90 !$OMP END MASTER 91 CALL bcast_omp(Var) 92 93 END SUBROUTINE bcast_i3 94 95 96 SUBROUTINE bcast_i4(var) 97 IMPLICIT NONE 98 INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 99 100 !$OMP MASTER 101 CALL bcast_mpi(Var) 102 !$OMP END MASTER 103 CALL bcast_omp(Var) 104 105 END SUBROUTINE bcast_i4 106 107 108 !! -- Les reels -- !! 109 110 SUBROUTINE bcast_r(var) 111 IMPLICIT NONE 112 REAL,INTENT(INOUT) :: Var 113 114 !$OMP MASTER 115 CALL bcast_mpi(Var) 116 !$OMP END MASTER 117 CALL bcast_omp(Var) 118 119 END SUBROUTINE bcast_r 120 121 SUBROUTINE bcast_r1(var) 122 IMPLICIT NONE 123 REAL,INTENT(INOUT) :: Var(:) 124 125 !$OMP MASTER 126 CALL bcast_mpi(Var) 127 !$OMP END MASTER 128 CALL bcast_omp(Var) 129 130 END SUBROUTINE bcast_r1 131 132 133 SUBROUTINE bcast_r2(var) 134 IMPLICIT NONE 135 REAL,INTENT(INOUT) :: Var(:,:) 136 137 !$OMP MASTER 138 CALL bcast_mpi(Var) 139 !$OMP END MASTER 140 CALL bcast_omp(Var) 141 142 END SUBROUTINE bcast_r2 143 144 145 SUBROUTINE bcast_r3(var) 146 IMPLICIT NONE 147 REAL,INTENT(INOUT) :: Var(:,:,:) 148 149 !$OMP MASTER 150 CALL bcast_mpi(Var) 151 !$OMP END MASTER 152 CALL bcast_omp(Var) 153 154 END SUBROUTINE bcast_r3 155 156 157 SUBROUTINE bcast_r4(var) 158 IMPLICIT NONE 159 REAL,INTENT(INOUT) :: Var(:,:,:,:) 160 161 !$OMP MASTER 162 CALL bcast_mpi(Var) 163 !$OMP END MASTER 164 CALL bcast_omp(Var) 165 166 END SUBROUTINE bcast_r4 167 168 169 !! -- Les booleens -- !! 170 171 SUBROUTINE bcast_l(var) 172 IMPLICIT NONE 173 LOGICAL,INTENT(INOUT) :: Var 174 !$OMP MASTER 175 CALL bcast_mpi(Var) 176 !$OMP END MASTER 177 CALL bcast_omp(Var) 178 179 END SUBROUTINE bcast_l 180 181 SUBROUTINE bcast_l1(var) 182 IMPLICIT NONE 183 LOGICAL,INTENT(INOUT) :: Var(:) 184 185 !$OMP MASTER 186 CALL bcast_mpi(Var) 187 !$OMP END MASTER 188 CALL bcast_omp(Var) 189 190 END SUBROUTINE bcast_l1 191 192 193 SUBROUTINE bcast_l2(var) 194 IMPLICIT NONE 195 LOGICAL,INTENT(INOUT) :: Var(:,:) 196 197 !$OMP MASTER 198 CALL bcast_mpi(Var) 199 !$OMP END MASTER 200 CALL bcast_omp(Var) 201 202 END SUBROUTINE bcast_l2 203 204 205 SUBROUTINE bcast_l3(var) 206 IMPLICIT NONE 207 LOGICAL,INTENT(INOUT) :: Var(:,:,:) 208 209 !$OMP MASTER 210 CALL bcast_mpi(Var) 211 !$OMP END MASTER 212 CALL bcast_omp(Var) 213 214 END SUBROUTINE bcast_l3 215 216 217 SUBROUTINE bcast_l4(var) 218 IMPLICIT NONE 219 LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 220 221 !$OMP MASTER 222 CALL bcast_mpi(Var) 223 !$OMP END MASTER 224 CALL bcast_omp(Var) 225 226 END SUBROUTINE bcast_l4 227 14 228 15 229 END MODULE transfert_mod -
codes/icosagcm/trunk/src/transfert_mpi.f90
r193 r266 74 74 INTEGER :: number 75 75 END TYPE t_message 76 77 78 INTERFACE bcast_mpi 79 MODULE PROCEDURE bcast_mpi_c, & 80 bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & 81 bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & 82 bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 83 END INTERFACE 84 85 76 86 77 87 CONTAINS … … 1646 1656 END SUBROUTINE gather_field 1647 1657 1658 1659 SUBROUTINE scatter_field(field_glo,field_loc) 1660 USE field_mod 1661 USE domain_mod 1662 USE mpi_mod 1663 USE mpipara 1664 IMPLICIT NONE 1665 TYPE(t_field),POINTER :: field_glo(:) 1666 TYPE(t_field),POINTER :: field_loc(:) 1667 INTEGER, ALLOCATABLE :: mpi_req(:) 1668 INTEGER, ALLOCATABLE :: status(:,:) 1669 INTEGER :: ireq,nreq 1670 INTEGER :: ind_glo,ind_loc 1671 1672 IF (.NOT. using_mpi) THEN 1673 1674 DO ind_loc=1,ndomain 1675 IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 1676 IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 1677 IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 1678 ENDDO 1679 1680 ELSE 1681 1682 nreq=ndomain 1683 IF (mpi_rank==0) nreq=nreq+ndomain_glo 1684 ALLOCATE(mpi_req(nreq)) 1685 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 1686 1687 1688 ireq=0 1689 IF (mpi_rank==0) THEN 1690 DO ind_glo=1,ndomain_glo 1691 ireq=ireq+1 1692 1693 IF (field_glo(ind_glo)%ndim==2) THEN 1694 CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , & 1695 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1696 1697 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 1698 CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , & 1699 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1700 1701 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 1702 CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , & 1703 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1704 ENDIF 1705 1706 ENDDO 1707 ENDIF 1708 1709 DO ind_loc=1,ndomain 1710 ireq=ireq+1 1711 1712 IF (field_loc(ind_loc)%ndim==2) THEN 1713 CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , & 1714 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1715 ELSE IF (field_loc(ind_loc)%ndim==3) THEN 1716 CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , & 1717 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1718 ELSE IF (field_loc(ind_loc)%ndim==4) THEN 1719 CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , & 1720 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1721 ENDIF 1722 1723 ENDDO 1724 1725 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 1726 1727 ENDIF 1728 1729 END SUBROUTINE scatter_field 1730 1731 1648 1732 1649 1733 SUBROUTINE trace_in … … 1661 1745 END SUBROUTINE trace_out 1662 1746 1747 1748 1749 1750 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1751 !! Definition des Broadcast --> 4D !! 1752 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1753 1754 !! -- Les chaine de charactère -- !! 1755 1756 SUBROUTINE bcast_mpi_c(var1) 1757 IMPLICIT NONE 1758 CHARACTER(LEN=*),INTENT(INOUT) :: Var1 1759 1760 CALL bcast_mpi_cgen(Var1,len(Var1)) 1761 1762 END SUBROUTINE bcast_mpi_c 1763 1764 !! -- Les entiers -- !! 1765 1766 SUBROUTINE bcast_mpi_i(var) 1767 USE mpipara 1768 IMPLICIT NONE 1769 INTEGER,INTENT(INOUT) :: Var 1770 1771 INTEGER :: var_tmp(1) 1772 1773 IF (is_mpi_master) var_tmp(1)=var 1774 CALL bcast_mpi_igen(Var_tmp,1) 1775 var=var_tmp(1) 1776 1777 END SUBROUTINE bcast_mpi_i 1778 1779 SUBROUTINE bcast_mpi_i1(var) 1780 IMPLICIT NONE 1781 INTEGER,INTENT(INOUT) :: Var(:) 1782 1783 CALL bcast_mpi_igen(Var,size(Var)) 1784 1785 END SUBROUTINE bcast_mpi_i1 1786 1787 SUBROUTINE bcast_mpi_i2(var) 1788 IMPLICIT NONE 1789 INTEGER,INTENT(INOUT) :: Var(:,:) 1790 1791 CALL bcast_mpi_igen(Var,size(Var)) 1792 1793 END SUBROUTINE bcast_mpi_i2 1794 1795 SUBROUTINE bcast_mpi_i3(var) 1796 IMPLICIT NONE 1797 INTEGER,INTENT(INOUT) :: Var(:,:,:) 1798 1799 CALL bcast_mpi_igen(Var,size(Var)) 1800 1801 END SUBROUTINE bcast_mpi_i3 1802 1803 SUBROUTINE bcast_mpi_i4(var) 1804 IMPLICIT NONE 1805 INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 1806 1807 CALL bcast_mpi_igen(Var,size(Var)) 1808 1809 END SUBROUTINE bcast_mpi_i4 1810 1811 1812 !! -- Les reels -- !! 1813 1814 SUBROUTINE bcast_mpi_r(var) 1815 USE mpipara 1816 IMPLICIT NONE 1817 REAL,INTENT(INOUT) :: Var 1818 REAL :: var_tmp(1) 1819 1820 IF (is_mpi_master) var_tmp(1)=var 1821 CALL bcast_mpi_rgen(Var_tmp,1) 1822 var=var_tmp(1) 1823 1824 END SUBROUTINE bcast_mpi_r 1825 1826 SUBROUTINE bcast_mpi_r1(var) 1827 IMPLICIT NONE 1828 REAL,INTENT(INOUT) :: Var(:) 1829 1830 CALL bcast_mpi_rgen(Var,size(Var)) 1831 1832 END SUBROUTINE bcast_mpi_r1 1833 1834 SUBROUTINE bcast_mpi_r2(var) 1835 IMPLICIT NONE 1836 REAL,INTENT(INOUT) :: Var(:,:) 1837 1838 CALL bcast_mpi_rgen(Var,size(Var)) 1839 1840 END SUBROUTINE bcast_mpi_r2 1841 1842 SUBROUTINE bcast_mpi_r3(var) 1843 IMPLICIT NONE 1844 REAL,INTENT(INOUT) :: Var(:,:,:) 1845 1846 CALL bcast_mpi_rgen(Var,size(Var)) 1847 1848 END SUBROUTINE bcast_mpi_r3 1849 1850 SUBROUTINE bcast_mpi_r4(var) 1851 IMPLICIT NONE 1852 REAL,INTENT(INOUT) :: Var(:,:,:,:) 1853 1854 CALL bcast_mpi_rgen(Var,size(Var)) 1855 1856 END SUBROUTINE bcast_mpi_r4 1857 1858 !! -- Les booleans -- !! 1859 1860 SUBROUTINE bcast_mpi_l(var) 1861 USE mpipara 1862 IMPLICIT NONE 1863 LOGICAL,INTENT(INOUT) :: Var 1864 LOGICAL :: var_tmp(1) 1865 1866 IF (is_mpi_master) var_tmp(1)=var 1867 CALL bcast_mpi_lgen(Var_tmp,1) 1868 var=var_tmp(1) 1869 1870 END SUBROUTINE bcast_mpi_l 1871 1872 SUBROUTINE bcast_mpi_l1(var) 1873 IMPLICIT NONE 1874 LOGICAL,INTENT(INOUT) :: Var(:) 1875 1876 CALL bcast_mpi_lgen(Var,size(Var)) 1877 1878 END SUBROUTINE bcast_mpi_l1 1879 1880 SUBROUTINE bcast_mpi_l2(var) 1881 IMPLICIT NONE 1882 LOGICAL,INTENT(INOUT) :: Var(:,:) 1883 1884 CALL bcast_mpi_lgen(Var,size(Var)) 1885 1886 END SUBROUTINE bcast_mpi_l2 1887 1888 SUBROUTINE bcast_mpi_l3(var) 1889 IMPLICIT NONE 1890 LOGICAL,INTENT(INOUT) :: Var(:,:,:) 1891 1892 CALL bcast_mpi_lgen(Var,size(Var)) 1893 1894 END SUBROUTINE bcast_mpi_l3 1895 1896 SUBROUTINE bcast_mpi_l4(var) 1897 IMPLICIT NONE 1898 LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 1899 1900 CALL bcast_mpi_lgen(Var,size(Var)) 1901 1902 END SUBROUTINE bcast_mpi_l4 1903 1904 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1905 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 1906 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1907 1908 SUBROUTINE bcast_mpi_cgen(var,nb) 1909 USE mpi_mod 1910 USE mpipara 1911 IMPLICIT NONE 1912 1913 CHARACTER(LEN=*),INTENT(INOUT) :: Var 1914 INTEGER,INTENT(IN) :: nb 1915 1916 IF (.NOT. using_mpi) RETURN 1917 1918 CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 1919 1920 END SUBROUTINE bcast_mpi_cgen 1921 1922 1923 1924 SUBROUTINE bcast_mpi_igen(var,nb) 1925 USE mpi_mod 1926 USE mpipara 1927 IMPLICIT NONE 1928 1929 INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 1930 INTEGER,INTENT(IN) :: nb 1931 1932 IF (.NOT. using_mpi) RETURN 1933 1934 CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 1935 1936 END SUBROUTINE bcast_mpi_igen 1937 1938 1939 1940 1941 SUBROUTINE bcast_mpi_rgen(var,nb) 1942 USE mpi_mod 1943 USE mpipara 1944 IMPLICIT NONE 1945 1946 REAL,DIMENSION(nb),INTENT(INOUT) :: Var 1947 INTEGER,INTENT(IN) :: nb 1948 1949 IF (.NOT. using_mpi) RETURN 1950 1951 CALL MPI_BCAST(Var,nb,MPI_REAL,mpi_master,comm_icosa,ierr) 1952 1953 END SUBROUTINE bcast_mpi_rgen 1954 1955 1956 1957 1958 SUBROUTINE bcast_mpi_lgen(var,nb) 1959 USE mpi_mod 1960 USE mpipara 1961 IMPLICIT NONE 1962 1963 LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 1964 INTEGER,INTENT(IN) :: nb 1965 1966 IF (.NOT. using_mpi) RETURN 1967 1968 CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 1969 1970 END SUBROUTINE bcast_mpi_lgen 1971 1972 1663 1973 END MODULE transfert_mpi_mod 1664 1974 -
codes/icosagcm/trunk/src/wind.f90
r196 r266 24 24 END SUBROUTINE un2ulonlat 25 25 26 SUBROUTINE ulonlat2un(f_ulon, f_ulat,f_u) 27 USE icosa 28 IMPLICIT NONE 29 TYPE(t_field), POINTER :: f_ulon(:), f_ulat(:) ! IN : velocity reconstructed at hexagons 30 TYPE(t_field), POINTER :: f_u(:) ! OUT : normal velocity components on edges 31 32 REAL(rstd),POINTER :: u(:,:), ulon(:,:), ulat(:,:) 33 INTEGER :: ind 34 35 DO ind=1,ndomain 36 IF (.NOT. assigned_domain(ind)) CYCLE 37 CALL swap_dimensions(ind) 38 CALL swap_geometry(ind) 39 u=f_u(ind) 40 ulon=f_ulon(ind) 41 ulat=f_ulat(ind) 42 CALL compute_ulonlat2un(ulon, ulat,u) 43 END DO 44 45 END SUBROUTINE ulonlat2un 26 46 27 47 SUBROUTINE compute_wind_centered(ue,ucenter) … … 298 318 END SUBROUTINE compute_wind_centered_lonlat_compound 299 319 320 SUBROUTINE compute_wind_centered_from_wind_lonlat_centered(ulon, ulat,uc) 321 USE icosa 322 323 IMPLICIT NONE 324 REAL(rstd) :: ulon(iim*jjm,llm) 325 REAL(rstd) :: ulat(iim*jjm,llm) 326 REAL(rstd) :: uc(iim*jjm,3,llm) 327 328 INTEGER :: i,j,ij,l 329 330 331 DO l=1,llm 332 DO j=jj_begin,jj_end 333 DO i=ii_begin,ii_end 334 ij=(j-1)*iim+i 335 uc(ij,:,l)=ulon(ij,l)*elon_i(ij,:)+ulat(ij,l)*elat_i(ij,:) 336 ENDDO 337 ENDDO 338 ENDDO 339 340 END SUBROUTINE compute_wind_centered_from_wind_lonlat_centered 341 342 343 344 SUBROUTINE compute_wind_perp_from_wind_centered(uc,un) 345 USE icosa 346 347 IMPLICIT NONE 348 REAL(rstd),INTENT(IN) :: uc(iim*jjm,3,llm) 349 REAL(rstd),INTENT(OUT) :: un(3*iim*jjm,llm) 350 351 INTEGER :: i,j,ij,l 352 353 354 DO l=1,llm 355 DO j=jj_begin,jj_end 356 DO i=ii_begin,ii_end 357 ij=(j-1)*iim+i 358 un(ij+u_right,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_right,:,l))*ep_e(ij+u_right,:)) 359 un(ij+u_lup,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_lup,:,l))*ep_e(ij+u_lup,:)) 360 un(ij+u_ldown,l) = sum(0.5*(uc(ij,:,l) + uc(ij+t_ldown,:,l))*ep_e(ij+u_ldown,:)) 361 ENDDO 362 ENDDO 363 ENDDO 364 365 END SUBROUTINE compute_wind_perp_from_wind_centered 366 367 300 368 SUBROUTINE compute_un2ulonlat(un, ulon, ulat) 301 369 USE icosa … … 313 381 END SUBROUTINE compute_un2ulonlat 314 382 383 SUBROUTINE compute_ulonlat2un(ulon, ulat,un) 384 USE icosa 385 386 IMPLICIT NONE 387 REAL(rstd),INTENT(IN) :: ulon(iim*jjm,llm) 388 REAL(rstd),INTENT(IN) :: ulat(iim*jjm,llm) 389 REAL(rstd),INTENT(OUT) :: un(3*iim*jjm,llm) 390 391 REAL(rstd) :: uc(iim*jjm,3,llm) 392 393 CALL compute_wind_centered_from_wind_lonlat_centered(ulon, ulat, uc) 394 CALL compute_wind_perp_from_wind_centered(uc, un) 395 396 END SUBROUTINE compute_ulonlat2un 397 398 315 399 END MODULE wind_mod -
codes/icosagcm/trunk/src/xios_mod.F90
r186 r266 420 420 421 421 END SUBROUTINE xios_write_field_finalize 422 422 423 SUBROUTINE xios_set_context 424 IMPLICIT NONE 425 TYPE(xios_context) :: ctx_hdl 426 427 !$OMP MASTER 428 CALL xios_get_handle("icosagcm",ctx_hdl) 429 CALL xios_set_current_context(ctx_hdl) 430 !$OMP END MASTER 431 432 END SUBROUTINE xios_set_context 423 433 #else 424 434 … … 447 457 SUBROUTINE xios_init_write_field 448 458 END SUBROUTINE xios_init_write_field 459 460 SUBROUTINE xios_set_context 461 END SUBROUTINE xios_set_context 462 463 449 464 #endif 450 465
Note: See TracChangeset
for help on using the changeset viewer.