Changeset 295 for codes/icosagcm/trunk
- Timestamp:
- 10/31/14 14:52:01 (10 years ago)
- Location:
- codes/icosagcm/trunk/src
- Files:
-
- 1 added
- 7 deleted
- 27 edited
Legend:
- Unmodified
- Added
- Removed
-
codes/icosagcm/trunk/src/advect_tracer.f90
r252 r295 26 26 SUBROUTINE init_advect_tracer 27 27 USE advect_mod 28 USE omp_para 28 29 REAL(rstd),POINTER :: tangent(:,:) 29 30 REAL(rstd),POINTER :: normal(:,:) … … 48 49 tangent=f_tangent(ind) 49 50 sqrt_leng=f_sqrt_leng(ind) 50 CALL init_advect(normal,tangent,sqrt_leng)51 IF (is_omp_level_master) CALL init_advect(normal,tangent,sqrt_leng) 51 52 END DO 52 53 … … 238 239 239 240 !--> flush dzqw, adzqw 240 ! !$OMP BARRIER241 !$OMP BARRIER 241 242 242 243 ! minmod-limited slope of q … … 258 259 259 260 ! 0 slope in top and bottom layers 260 IF ( omp_first) THEN261 IF (is_omp_first_level) THEN 261 262 DO ij=ijb,ije 262 263 dzq(ij,1)=0. … … 264 265 ENDIF 265 266 266 IF ( omp_last) THEN267 IF (is_omp_last_level) THEN 267 268 DO ij=ijb,ije 268 269 dzq(ij,llm)=0. … … 271 272 272 273 !---> flush dzq 273 ! !$OMP BARRIER274 !$OMP BARRIER 274 275 275 276 ! sigw = fraction of mass that leaves level l/l+1 … … 290 291 END DO 291 292 ! wq = 0 at top and bottom 292 IF ( omp_first) THEN293 IF (is_omp_first_level) THEN 293 294 DO ij=ijb,ije 294 295 wq(ij,1)=0. … … 296 297 ENDIF 297 298 298 IF ( omp_last) THEN299 IF (is_omp_last_level) THEN 299 300 DO ij=ijb,ije 300 301 wq(ij,llm+1)=0. … … 303 304 304 305 ! --> flush wq 305 ! !$OMP BARRIER306 !$OMP BARRIER 306 307 307 308 -
codes/icosagcm/trunk/src/caldyn_gcm.f90
r286 r295 33 33 USE exner_mod 34 34 USE mpipara 35 USE omp_para 35 36 IMPLICIT NONE 36 37 CHARACTER(len=255) :: def … … 50 51 STOP 51 52 END SELECT 52 IF (is_m pi_root) PRINT *, 'caldyn_conserv=',def53 IF (is_master) PRINT *, 'caldyn_conserv=',def 53 54 54 55 CALL allocate_caldyn … … 72 73 CALL allocate_field(f_qv,field_z,type_real,llm) 73 74 74 CALL allocate_field(f_buf_i, field_t,type_real,llm )75 CALL allocate_field(f_buf_i, field_t,type_real,llm,name="buffer_i") 75 76 CALL allocate_field(f_buf_p, field_t,type_real,llm+1) 76 77 CALL allocate_field(f_buf_u3d, field_t,type_real,3,llm) ! 3D vel at cell centers … … 102 103 INTEGER :: ind,i,j,ij,l 103 104 104 IF ( omp_first) THEN105 IF (is_omp_first_level) THEN 105 106 DO ind=1,ndomain 106 107 IF (.NOT. assigned_domain(ind)) CYCLE … … 128 129 ENDIF 129 130 130 !!$OMP BARRIER131 !$OMP BARRIER 131 132 END SUBROUTINE caldyn_BC 132 133 … … 143 144 USE omp_para 144 145 USE output_field_mod 146 USE checksum_mod 145 147 IMPLICIT NONE 146 148 LOGICAL,INTENT(IN) :: write_out … … 291 293 END SELECT 292 294 293 ! !$OMP BARRIER295 !$OMP BARRIER 294 296 IF (write_out) THEN 295 297 296 IF (is_m pi_root) PRINT *,'CALL write_output_fields'298 IF (is_master) PRINT *,'CALL write_output_fields' 297 299 298 300 ! ---> for openMP test to fix later … … 450 452 451 453 !!! Compute exner function and geopotential 452 DO l = 1,llm 454 IF (is_omp_level_master) THEN ! no openMP on vertical due to dependency 455 DO l = 1,llm 453 456 ! !$OMP DO SCHEDULE(STATIC) 454 457 !DIR$ SIMD 455 DO ij=ij_begin_ext,ij_end_ext456 p_ik = ptop + mass_ak(l) + mass_bk(l)*ps(ij) ! FIXME : leave ps for the moment ; change ps to Ms later457 ! p_ik = ptop + g*(mass_ak(l)+ mass_bk(l)*ps(i,j))458 exner_ik = cpp * (p_ik/preff) ** kappa459 pk(ij,l) = exner_ik458 DO ij=ij_begin_ext,ij_end_ext 459 p_ik = ptop + mass_ak(l) + mass_bk(l)*ps(ij) ! FIXME : leave ps for the moment ; change ps to Ms later 460 ! p_ik = ptop + g*(mass_ak(l)+ mass_bk(l)*ps(i,j)) 461 exner_ik = cpp * (p_ik/preff) ** kappa 462 pk(ij,l) = exner_ik 460 463 ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz 461 geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik464 geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik 462 465 ENDDO 463 ENDDO464 466 ENDDO 467 ENDIF 465 468 ELSE 466 469 ! We are using a Lagrangian vertical coordinate … … 471 474 IF(boussinesq) THEN ! compute only geopotential : pressure pk will be computed in compute_caldyn_horiz 472 475 ! specific volume 1 = dphi/g/rhodz 473 DO l = 1,llm 476 IF (is_omp_level_master) THEN ! no openMP on vertical due to dependency 477 DO l = 1,llm 474 478 ! !$OMP DO SCHEDULE(STATIC) 475 479 !DIR$ SIMD … … 477 481 geopot(ij,l+1) = geopot(ij,l) + g*rhodz(ij,l) 478 482 ENDDO 479 ENDDO 483 ENDDO 484 ENDIF 480 485 ELSE ! non-Boussinesq, compute geopotential and Exner pressure 481 486 ! uppermost layer 482 !DIR$ SIMD 483 DO ij=ij_begin_ext,ij_end_ext 484 pk(ij,llm) = ptop + (.5*g)*rhodz(ij,llm) 485 END DO 486 ! other layers 487 DO l = llm-1, 1, -1 488 489 ! !$OMP DO SCHEDULE(STATIC) 490 !DIR$ SIMD 491 DO ij=ij_begin_ext,ij_end_ext 492 pk(ij,l) = pk(ij,l+1) + (.5*g)*(rhodz(ij,l)+rhodz(ij,l+1)) 493 END DO 494 END DO 487 IF (is_omp_level_master) THEN ! no openMP on vertical due to dependency 488 489 !DIR$ SIMD 490 DO ij=ij_begin_ext,ij_end_ext 491 pk(ij,llm) = ptop + (.5*g)*rhodz(ij,llm) 492 END DO 493 ! other layers 494 DO l = llm-1, 1, -1 495 496 ! !$OMP DO SCHEDULE(STATIC) 497 !DIR$ SIMD 498 DO ij=ij_begin_ext,ij_end_ext 499 pk(ij,l) = pk(ij,l+1) + (.5*g)*(rhodz(ij,l)+rhodz(ij,l+1)) 500 END DO 501 END DO 495 502 ! surface pressure (for diagnostics) 496 DO ij=ij_begin_ext,ij_end_ext497 ps(ij) = pk(ij,1) + (.5*g)*rhodz(ij,1)498 END DO503 DO ij=ij_begin_ext,ij_end_ext 504 ps(ij) = pk(ij,1) + (.5*g)*rhodz(ij,1) 505 END DO 499 506 500 507 ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz 501 DO l = 1,llm508 DO l = 1,llm 502 509 503 510 ! !$OMP DO SCHEDULE(STATIC) 504 511 !DIR$ SIMD 505 DO ij=ij_begin_ext,ij_end_ext 506 p_ik = pk(ij,l) 507 exner_ik = cpp * (p_ik/preff) ** kappa 508 geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik 509 pk(ij,l) = exner_ik 510 ENDDO 511 ENDDO 512 DO ij=ij_begin_ext,ij_end_ext 513 p_ik = pk(ij,l) 514 exner_ik = cpp * (p_ik/preff) ** kappa 515 geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik 516 pk(ij,l) = exner_ik 517 ENDDO 518 ENDDO 519 ENDIF 512 520 END IF 513 521 514 522 END IF 523 524 !ym flush geopot 525 !$OMP BARRIER 515 526 516 527 CALL trace_end("compute_geopot") … … 799 810 CALL trace_start("compute_caldyn_vert") 800 811 801 ! !$OMP BARRIER812 !$OMP BARRIER 802 813 !!! cumulate mass flux convergence from top to bottom 803 DO l = llm-1, 1, -1 814 IF (is_omp_level_master) THEN 815 DO l = llm-1, 1, -1 804 816 ! IF (caldyn_conserv==energy) CALL test_message(req_qu) 805 817 806 818 !!$OMP DO SCHEDULE(STATIC) 807 819 !DIR$ SIMD 808 DO ij=ij_begin,ij_end 809 convm(ij,l) = convm(ij,l) + convm(ij,l+1) 820 DO ij=ij_begin,ij_end 821 convm(ij,l) = convm(ij,l) + convm(ij,l+1) 822 ENDDO 810 823 ENDDO 811 ENDDO 812 813 ! IMPLICIT FLUSH on convm 824 ENDIF 825 826 !$OMP BARRIER 827 ! FLUSH on convm 814 828 !!!!!!!!!!!!!!!!!!!!!!!!! 815 829 816 830 ! compute dps 817 IF ( omp_first) THEN831 IF (is_omp_first_level) THEN 818 832 !DIR$ SIMD 819 833 DO ij=ij_begin,ij_end … … 834 848 ENDDO 835 849 850 !--> flush wflux 851 !$OMP BARRIER 852 836 853 DO l=ll_begin,ll_endm1 837 854 !DIR$ SIMD … … 847 864 ENDDO 848 865 ENDDO 866 849 867 850 868 ! Compute vertical transport … … 859 877 860 878 !--> flush wwuu 861 ! !$OMP BARRIER879 !$OMP BARRIER 862 880 863 881 ! Add vertical transport to du … … 1018 1036 ps = f_ps(ind) 1019 1037 p = f_p(ind) 1038 !$OMP BARRIER 1020 1039 CALL compute_pression(ps,p,0) 1021 1040 pk = f_pk(ind) 1022 1041 pks = f_pks(ind) 1042 !$OMP BARRIER 1023 1043 CALL compute_exner(ps,p,pks,pk,0) 1044 !$OMP BARRIER 1024 1045 theta_rhodz = f_theta_rhodz(ind) 1025 1046 theta = f_theta(ind) -
codes/icosagcm/trunk/src/check_conserve.f90
r286 r295 9 9 10 10 PUBLIC init_check_conserve, check_conserve 11 REAL(rstd),SAVE:: mtot0,ztot0,etot0,ang0,stot0,rmsv0 12 !$OMP THREADPRIVATE(mtot0,ztot0,etot0,ang0,stot0,rmsv0) 13 REAL(rstd),SAVE:: etot,ang,stot,rmsv 14 !$OMP THREADPRIVATE(etot,ang,stot,rmsv) 15 REAL(rstd),SAVE:: ztot 16 !$OMP THREADPRIVATE(ztot) 11 REAL(rstd),SAVE:: mtot0,ztot0,etot0,angtot0,stot0,rmsvtot0 12 !$OMP THREADPRIVATE(mtot0,ztot0,etot0,angtot0,stot0,rmsvtot0) 17 13 18 14 CONTAINS … … 36 32 USE caldyn_gcm_mod 37 33 USE exner_mod 38 USE mpipara, ONLY : is_mpi_root, comm_icosa 34 USE mpipara, ONLY : is_mpi_master, comm_icosa 35 USE omp_para 39 36 IMPLICIT NONE 40 37 TYPE(t_field),POINTER :: f_ps(:) … … 48 45 INTEGER::ind,ierr 49 46 REAL(rstd) :: mtot, rmsdpdt 50 51 etot=0.0; ang=0.0;stot=0.0;rmsv=0.0 52 ztot = 0.0 53 47 REAL(rstd) :: etot, stot, angtot, rmsvtot, ztot 48 49 CALL transfert_request(f_ue,req_e1_vect) 54 50 CALL pression(f_ps,f_p) 55 51 … … 65 61 CALL vorticity(f_ue,f_vort) 66 62 CALL check_mass_conserve(f_ps,f_dps,mtot,rmsdpdt) 67 CALL check_PV 63 CALL check_PV(ztot) 68 64 CALL exner(f_ps,f_p,f_pks,f_pk) 69 CALL check_EN(f_ue,f_theta_rhodz,f_phis) 70 71 IF (is_mpi_root) THEN 72 !$OMP MASTER 73 IF ( it == itau0 ) Then 65 CALL check_EN(f_ue,f_theta_rhodz,f_phis, etot, stot, angtot, rmsvtot) 66 67 IF (is_master) THEN 68 IF ( it == itau0 ) THEN 74 69 ztot0 = ztot 75 70 mtot0 = mtot 76 71 etot0 = etot 77 ang 0 = ang72 angtot0 = angtot 78 73 stot0 = stot 79 74 END IF 80 75 81 rmsv =SQRT(rmsv/mtot)76 rmsvtot=SQRT(rmsvtot/mtot) 82 77 ztot=ztot/ztot0-1. ; mtot=mtot/mtot0-1. 83 etot=etot/etot0-1. ; ang =ang/ang0-1. ; stot=stot/stot0-1.78 etot=etot/etot0-1. ; angtot=angtot/angtot0-1. ; stot=stot/stot0-1. 84 79 rmsdpdt= daysec*1.e-2*sqrt(rmsdpdt/ncell_glo) 85 80 86 81 OPEN(134,file="checkconsicosa.txt",position='append') 87 WRITE(134,4000)mtot,rmsdpdt,etot,ztot,stot,rmsv ,ang88 WRITE(134,*)mtot,rmsdpdt,etot,ztot,stot,rmsv ,ang82 WRITE(134,4000)mtot,rmsdpdt,etot,ztot,stot,rmsvtot,angtot 83 WRITE(134,*)mtot,rmsdpdt,etot,ztot,stot,rmsvtot,angtot 89 84 WRITE(134,*)"==================================================" 90 WRITE(*,4000)mtot,rmsdpdt,etot,ztot,stot,rmsv ,ang85 WRITE(*,4000)mtot,rmsdpdt,etot,ztot,stot,rmsvtot,angtot 91 86 92 87 4000 FORMAT(10x,'masse',5x,'rmsdpdt',5x,'energie',5x,'enstrophie' & 93 88 ,5x,'entropie',5x,'rmsv',5x,'mt.ang',/,'GLOB ' & 94 ,e10.3,e13.6,5e1 0.3/)89 ,e10.3,e13.6,5e13.3/) 95 90 close(134) 96 !$OMP END MASTER91 97 92 END IF 98 93 END SUBROUTINE check_conserve … … 105 100 USE transfert_omp_mod 106 101 USE icosa 102 USE omp_para 107 103 IMPLICIT NONE 108 104 TYPE(t_field),POINTER :: f_ps(:) … … 117 113 mloc=0.0; rmsloc=0.0 118 114 DO ind=1,ndomain 119 IF (.NOT. assigned_domain(ind) ) CYCLE115 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 120 116 CALL swap_dimensions(ind) 121 117 CALL swap_geometry(ind) … … 141 137 !$OMP END MASTER 142 138 ELSE 143 139 mtot=mloc 140 rmsdpdt=rmsloc 144 141 ENDIF 145 142 … … 148 145 !--------------------------------------------------------------------- 149 146 150 SUBROUTINE check_en(f_ue,f_theta_rhodz,f_phis )147 SUBROUTINE check_en(f_ue,f_theta_rhodz,f_phis, etot, stot, angtot, rmsvtot) 151 148 USE icosa 152 149 USE pression_mod 153 150 USE vorticity_mod 151 USE mpi_mod 152 USE mpipara 153 USE transfert_omp_mod 154 154 IMPLICIT NONE 155 155 TYPE(t_field), POINTER :: f_ue(:) 156 156 TYPE(t_field), POINTER :: f_theta_rhodz(:) 157 157 TYPE(t_field), POINTER :: f_phis(:) 158 REAL(rstd),INTENT(OUT) :: etot, stot, angtot, rmsvtot 158 159 REAL(rstd), POINTER :: ue(:,:) 159 160 REAL(rstd), POINTER :: p(:,:) … … 162 163 REAL(rstd), POINTER :: phis(:) 163 164 REAL(rstd), POINTER :: rhodz(:,:) 165 REAL(rstd) :: e, s, ang, rmsv 166 REAL(rstd) :: e_mpi, s_mpi, ang_mpi, rmsv_mpi 164 167 INTEGER :: ind 165 168 169 e = 0 ; s = 0 ; ang = 0 ; rmsv = 0 166 170 167 171 DO ind=1,ndomain … … 175 179 pk=f_pk(ind) 176 180 phis=f_phis(ind) 177 CALL compute_en(ind,ue,p,rhodz,theta_rhodz,pk,phis )181 CALL compute_en(ind,ue,p,rhodz,theta_rhodz,pk,phis, e, s, ang, rmsv) 178 182 END DO 179 183 184 IF (using_mpi) THEN 185 CALL reduce_sum_omp(e, e_mpi) 186 CALL reduce_sum_omp(s, s_mpi) 187 CALL reduce_sum_omp(ang, ang_mpi) 188 CALL reduce_sum_omp(rmsv, rmsv_mpi) 189 !$OMP MASTER 190 CALL MPI_REDUCE(e_mpi, etot, 1, MPI_REAL8, MPI_SUM, 0, comm_icosa, ierr) 191 CALL MPI_REDUCE(s_mpi, stot, 1, MPI_REAL8, MPI_SUM, 0, comm_icosa, ierr) 192 CALL MPI_REDUCE(ang_mpi, angtot, 1, MPI_REAL8, MPI_SUM, 0, comm_icosa, ierr) 193 CALL MPI_REDUCE(rmsv_mpi, rmsvtot, 1, MPI_REAL8, MPI_SUM, 0, comm_icosa, ierr) 194 !$OMP END MASTER 195 ELSE 196 etot=e 197 stot=s 198 angtot=ang 199 rmsvtot=rmsv 200 ENDIF 201 180 202 END SUBROUTINE check_en 181 203 182 SUBROUTINE compute_en(ind,u,p,rhodz,theta_rhodz,pk,phis )204 SUBROUTINE compute_en(ind,u,p,rhodz,theta_rhodz,pk,phis, e, s, ang, rmsv) 183 205 USE icosa 184 206 USE disvert_mod 185 207 USE wind_mod 208 USE omp_para 186 209 IMPLICIT NONE 187 210 INTEGER,INTENT(IN)::ind … … 192 215 REAL(rstd),INTENT(IN) :: pk(iim*jjm,llm) 193 216 REAL(rstd),INTENT(IN) :: phis(iim*jjm) 217 REAL(rstd),INTENT(INOUT) :: e 218 REAL(rstd),INTENT(INOUT) :: s 219 REAL(rstd),INTENT(INOUT) :: ang 220 REAL(rstd),INTENT(INOUT) :: rmsv 221 194 222 REAL(rstd):: theta(iim*jjm,llm) 195 223 REAL(rstd)::KE(iim*jjm,llm) … … 204 232 205 233 206 DO l = 1, llm234 DO l = ll_begin, ll_end 207 235 DO j=jj_begin,jj_end 208 236 DO i=ii_begin,ii_end … … 211 239 theta(ij,l) = theta_rhodz(ij,l)/rhodz(ij,l) 212 240 IF (domain(ind)%own(i,j)) THEN 213 s tot = stot+ Ai(ij)*theta_rhodz(ij,l)241 s = s + Ai(ij)*theta_rhodz(ij,l) 214 242 END IF 215 243 END DO … … 217 245 END DO 218 246 219 DO l = 1, llm247 DO l = ll_begin,ll_end 220 248 DO j=jj_begin,jj_end 221 249 DO i=ii_begin,ii_end … … 234 262 END DO 235 263 236 DO l = 1, llm264 DO l = ll_begin,ll_end 237 265 DO j=jj_begin,jj_end 238 266 DO i=ii_begin,ii_end 239 267 ij=(j-1)*iim+i 240 268 IF (domain(ind)%own(i,j)) THEN 241 e tot = etot+ masse(ij,l)*(phis(ij)+theta(ij,l)*pk(ij,l)+KE(ij,l))269 e = e + masse(ij,l)*(phis(ij)+theta(ij,l)*pk(ij,l)+KE(ij,l)) 242 270 END IF 243 271 END DO … … 251 279 radomeg = rad*omega 252 280 253 DO l = 1, llm281 DO l = ll_begin,ll_end 254 282 DO j=jj_begin,jj_end 255 283 DO i=ii_begin,ii_end … … 267 295 !--------------------------------------------------------------------- 268 296 269 SUBROUTINE check_PV 270 USE icosa 271 IMPLICIT NONE 297 SUBROUTINE check_PV(ztot) 298 USE icosa 299 USE mpi_mod 300 USE mpipara 301 USE transfert_omp_mod 302 IMPLICIT NONE 303 REAL(rstd),INTENT(OUT) :: ztot 272 304 REAL(rstd), POINTER :: vort(:,:) 273 305 REAL(rstd), POINTER :: rhodz(:,:) 274 306 INTEGER :: ind 275 307 REAL(rstd) :: z,z_mpi 308 309 z=0 276 310 DO ind=1,ndomain 277 311 IF (.NOT. assigned_domain(ind)) CYCLE … … 280 314 vort=f_vort(ind) 281 315 rhodz=f_rhodz(ind) 282 CALL compute_PV(vort,rhodz )316 CALL compute_PV(vort,rhodz,z) 283 317 ENDDO 318 319 IF (using_mpi) THEN 320 CALL reduce_sum_omp(z, z_mpi) 321 !$OMP MASTER 322 CALL MPI_REDUCE(z_mpi, ztot, 1, MPI_REAL8, MPI_SUM, 0, comm_icosa, ierr) 323 !$OMP END MASTER 324 ELSE 325 ztot=z 326 ENDIF 284 327 285 328 END SUBROUTINE check_PV 286 329 287 SUBROUTINE compute_PV(vort,rhodz )330 SUBROUTINE compute_PV(vort,rhodz,z) 288 331 USE icosa 289 332 USE disvert_mod 333 USE omp_para 290 334 IMPLICIT NONE 291 335 REAL(rstd),INTENT(IN) :: vort(2*iim*jjm,llm) 292 336 REAL(rstd),INTENT(IN) :: rhodz(iim*jjm,llm) 337 REAL(rstd),INTENT(INOUT) :: z 293 338 REAL(rstd)::qv1,qv2 294 339 REAL(rstd)::hv1,hv2 … … 297 342 hv1 = 0.0 ; hv2 = 0.0 298 343 299 DO l = 1,llm344 DO l = ll_begin,ll_end 300 345 DO j=jj_begin+1,jj_end-1 301 346 DO i=ii_begin+1,ii_end-1 … … 313 358 qv2 =( vort(ij+z_down,l)+fv(ij+z_down) )/hv2 314 359 315 z tot = ztot+ (qv1*qv1*hv1 + qv2*qv2*hv2)360 z = z + (qv1*qv1*hv1 + qv2*qv2*hv2) 316 361 317 362 ENDDO 318 363 ENDDO 364 319 365 ENDDO 320 366 -
codes/icosagcm/trunk/src/dissip_gcm.f90
r286 r295 71 71 USE time_mod 72 72 USE transfert_omp_mod 73 USE omp_para 73 74 IMPLICIT NONE 74 75 … … 100 101 CASE('none') 101 102 rayleigh_friction_type=0 102 IF (is_m pi_root) PRINT *, 'No Rayleigh friction'103 IF (is_master) PRINT *, 'No Rayleigh friction' 103 104 CASE('dcmip2_schaer_noshear') 104 105 rayleigh_friction_type=1 105 106 rayleigh_shear=0 106 IF (is_m pi_root) PRINT *, 'Rayleigh friction : Schaer-like mountain without shear DCMIP2.1'107 IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain without shear DCMIP2.1' 107 108 CASE('dcmip2_schaer_shear') 108 109 rayleigh_shear=1 109 110 rayleigh_friction_type=2 110 IF (is_m pi_root) PRINT *, 'Rayleigh friction : Schaer-like mountain with shear DCMIP2.2'111 IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain with shear DCMIP2.2' 111 112 CASE DEFAULT 112 IF (is_m pi_root) PRINT *, 'Bad selector : rayleigh_friction_type =', TRIM(rayleigh_friction_key), ' in dissip_gcm.f90/init_dissip'113 IF (is_master) PRINT *, 'Bad selector : rayleigh_friction_type =', TRIM(rayleigh_friction_key), ' in dissip_gcm.f90/init_dissip' 113 114 STOP 114 115 END SELECT … … 119 120 rayleigh_tau = rayleigh_tau / scale_factor 120 121 IF(rayleigh_tau<=0) THEN 121 IF (is_m pi_root) PRINT *, 'Forbidden : negative value for rayleigh_friction_tau =',rayleigh_tau122 IF (is_master) PRINT *, 'Forbidden : negative value for rayleigh_friction_tau =',rayleigh_tau 122 123 STOP 123 124 END IF … … 156 157 cdivgrad=-1 157 158 cgradrot=-1 158 159 160 !$OMP BARRIER 161 !$OMP MASTER 159 162 DO ind=1,ndomain 160 IF (.NOT. assigned_domain(ind)) CYCLE161 163 CALL swap_dimensions(ind) 162 164 CALL swap_geometry(ind) … … 175 177 ENDDO 176 178 ENDDO 177 178 179 !$OMP END MASTER 180 !$OMP BARRIER 179 181 180 182 DO it=1,20 … … 184 186 CALL transfert_request(f_u,req_e1_vect) 185 187 DO ind=1,ndomain 186 IF (.NOT. assigned_domain(ind) ) CYCLE188 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 187 189 CALL swap_dimensions(ind) 188 190 CALL swap_geometry(ind) … … 197 199 198 200 DO ind=1,ndomain 199 IF (.NOT. assigned_domain(ind) ) CYCLE201 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 200 202 CALL swap_dimensions(ind) 201 203 CALL swap_geometry(ind) … … 214 216 215 217 IF (using_mpi) THEN 216 CALL reduce_ sum_omp(dumax,dumax1)218 CALL reduce_max_omp(dumax,dumax1) 217 219 !$OMP MASTER 218 220 CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr) … … 220 222 CALL bcast_omp(dumax) 221 223 ELSE 222 CALL allreduce_ sum_omp(dumax,dumax1)224 CALL allreduce_max_omp(dumax,dumax1) 223 225 dumax=dumax1 224 226 ENDIF 225 227 226 228 DO ind=1,ndomain 227 IF (.NOT. assigned_domain(ind) ) CYCLE229 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 228 230 CALL swap_dimensions(ind) 229 231 CALL swap_geometry(ind) … … 232 234 u=du/dumax 233 235 ENDDO 234 IF (is_m pi_root) PRINT *,"gradiv : it :",it ,": dumax",dumax236 IF (is_master) PRINT *,"gradiv : it :",it ,": dumax",dumax 235 237 236 238 ENDDO 237 IF (is_m pi_root) PRINT *,"gradiv : dumax",dumax238 IF (is_m pi_root) PRINT *, 'mean T-cell edge size (km)', 1.45*radius/iim_glo/1000., &239 IF (is_master) PRINT *,"gradiv : dumax",dumax 240 IF (is_master) PRINT *, 'mean T-cell edge size (km)', 1.45*radius/iim_glo/1000., & 239 241 'effective T-cell half-edge size (km)', dumax**(-.5/nitergdiv)/1000 240 IF (is_m pi_root) PRINT *, 'Max. time step assuming c=340 m/s and Courant number=2.8 :', &242 IF (is_master) PRINT *, 'Max. time step assuming c=340 m/s and Courant number=2.8 :', & 241 243 2.8/340.*dumax**(-.5/nitergdiv) 242 244 243 245 cgraddiv=dumax**(-1./nitergdiv) 244 IF (is_mpi_root) PRINT *,"cgraddiv : ",cgraddiv 245 246 IF (is_master) PRINT *,"cgraddiv : ",cgraddiv 247 248 !$OMP BARRIER 249 !$OMP MASTER 246 250 DO ind=1,ndomain 247 IF (.NOT. assigned_domain(ind)) CYCLE248 251 CALL swap_dimensions(ind) 249 252 CALL swap_geometry(ind) … … 262 265 ENDDO 263 266 ENDDO 267 !$OMP END MASTER 268 !$OMP BARRIER 264 269 265 270 … … 270 275 CALL transfert_request(f_u,req_e1_vect) 271 276 DO ind=1,ndomain 272 IF (.NOT. assigned_domain(ind) ) CYCLE277 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 273 278 CALL swap_dimensions(ind) 274 279 CALL swap_geometry(ind) … … 283 288 284 289 DO ind=1,ndomain 285 IF (.NOT. assigned_domain(ind) ) CYCLE290 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 286 291 CALL swap_dimensions(ind) 287 292 CALL swap_geometry(ind) … … 300 305 301 306 IF (using_mpi) THEN 302 CALL reduce_ sum_omp(dumax,dumax1)307 CALL reduce_max_omp(dumax,dumax1) 303 308 !$OMP MASTER 304 309 CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr) … … 306 311 CALL bcast_omp(dumax) 307 312 ELSE 308 CALL allreduce_ sum_omp(dumax,dumax1)313 CALL allreduce_max_omp(dumax,dumax1) 309 314 dumax=dumax1 310 315 ENDIF … … 312 317 313 318 DO ind=1,ndomain 314 IF (.NOT. assigned_domain(ind) ) CYCLE319 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 315 320 CALL swap_dimensions(ind) 316 321 CALL swap_geometry(ind) … … 320 325 ENDDO 321 326 322 IF (is_m pi_root) PRINT *,"gradrot : it :",it ,": dumax",dumax327 IF (is_master) PRINT *,"gradrot : it :",it ,": dumax",dumax 323 328 324 329 ENDDO 325 IF (is_m pi_root) PRINT *,"gradrot : dumax",dumax330 IF (is_master) PRINT *,"gradrot : dumax",dumax 326 331 327 332 cgradrot=dumax**(-1./nitergrot) 328 IF (is_m pi_root) PRINT *,"cgradrot : ",cgradrot333 IF (is_master) PRINT *,"cgradrot : ",cgradrot 329 334 330 335 331 336 337 !$OMP BARRIER 338 !$OMP MASTER 332 339 DO ind=1,ndomain 333 IF (.NOT. assigned_domain(ind)) CYCLE334 340 CALL swap_dimensions(ind) 335 341 CALL swap_geometry(ind) … … 344 350 ENDDO 345 351 ENDDO 352 !$OMP END MASTER 353 !$OMP BARRIER 346 354 347 355 DO it=1,20 … … 351 359 CALL transfert_request(f_theta,req_i1) 352 360 DO ind=1,ndomain 353 IF (.NOT. assigned_domain(ind) ) CYCLE361 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 354 362 CALL swap_dimensions(ind) 355 363 CALL swap_geometry(ind) … … 364 372 365 373 DO ind=1,ndomain 366 IF (.NOT. assigned_domain(ind) ) CYCLE374 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 367 375 CALL swap_dimensions(ind) 368 376 CALL swap_geometry(ind) … … 379 387 380 388 IF (using_mpi) THEN 381 CALL reduce_ sum_omp(dthetamax ,dthetamax1)389 CALL reduce_max_omp(dthetamax ,dthetamax1) 382 390 !$OMP MASTER 383 391 CALL MPI_ALLREDUCE(dthetamax1,dthetamax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr) … … 385 393 CALL bcast_omp(dthetamax) 386 394 ELSE 387 CALL allreduce_ sum_omp(dthetamax,dthetamax1)395 CALL allreduce_max_omp(dthetamax,dthetamax1) 388 396 dumax=dumax1 389 397 ENDIF 390 398 391 IF (is_m pi_root) PRINT *,"divgrad : it :",it ,": dthetamax",dthetamax399 IF (is_master) PRINT *,"divgrad : it :",it ,": dthetamax",dthetamax 392 400 393 401 DO ind=1,ndomain 394 IF (.NOT. assigned_domain(ind) ) CYCLE402 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 395 403 CALL swap_dimensions(ind) 396 404 CALL swap_geometry(ind) … … 401 409 ENDDO 402 410 403 IF (is_m pi_root) PRINT *,"divgrad : divgrad",dthetamax411 IF (is_master) PRINT *,"divgrad : divgrad",dthetamax 404 412 405 413 cdivgrad=dthetamax**(-1./niterdivgrad) 406 IF (is_m pi_root) PRINT *,"cdivgrad : ",cdivgrad414 IF (is_master) PRINT *,"cdivgrad : ",cdivgrad 407 415 408 416 … … 431 439 dtdissip=itau_dissip*dt 432 440 ELSE 433 IF (is_m pi_root) PRINT *,"No dissipation time set, setting itau_dissip to 1000000000"441 IF (is_master) PRINT *,"No dissipation time set, setting itau_dissip to 1000000000" 434 442 itau_dissip=100000000 435 443 END IF 436 444 itau_dissip=MAX(1,itau_dissip) 437 IF (is_m pi_root) PRINT *,"mintau ",mintau,"itau_dissip",itau_dissip," dtdissip ",dtdissip445 IF (is_master) PRINT *,"mintau ",mintau,"itau_dissip",itau_dissip," dtdissip ",dtdissip 438 446 439 447 END SUBROUTINE init_dissip … … 713 721 714 722 CALL trace_start("divgrad") 715 723 716 724 DO ind=1,ndomain 717 725 IF (.NOT. assigned_domain(ind)) CYCLE -
codes/icosagcm/trunk/src/domain.f90
r266 r295 449 449 450 450 ind=0 451 DO rank=0,omp_ size-1452 nb_domain=ndomain/omp_ size453 IF ( rank < MOD(ndomain,omp_ size) ) nb_domain=nb_domain+1451 DO rank=0,omp_domain_size-1 452 nb_domain=ndomain/omp_domain_size 453 IF ( rank < MOD(ndomain,omp_domain_size) ) nb_domain=nb_domain+1 454 454 455 455 DO i=1,nb_domain 456 456 ind=ind+1 457 IF (rank==omp_ rank) THEN457 IF (rank==omp_domain_rank) THEN 458 458 assigned_domain(ind)=.TRUE. 459 459 PRINT *,"Rank ",mpi_rank," task ",rank," local domain : ",ind," global domain ",domloc_glo_ind(ind) -
codes/icosagcm/trunk/src/etat0.f90
r286 r295 25 25 USE etat0_dcmip4_mod, ONLY : etat0_dcmip4=>etat0 26 26 USE etat0_heldsz_mod, ONLY : etat0_heldsz=>etat0 27 USE dynetat0_gcm_mod, ONLY : dynetat0_start=>etat028 USE dynetat0_hz_mod, ONLY : dynetat0_hz=>etat029 27 USE etat0_start_file_mod, ONLY : etat0_start_file=>etat0 30 28 … … 80 78 CASE ('dcmip3') 81 79 CALL etat0_dcmip3(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 82 80 CASE ('dcmip4') 83 81 IF(nqtot<2) THEN 84 82 IF (is_mpi_root) THEN … … 87 85 STOP 88 86 END IF 89 CALL etat0_dcmip4(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 90 CASE ('readnf_start') 91 print*,"readnf_start used" 92 CALL dynetat0_start(f_ps,f_phis,f_theta_rhodz,f_u,f_q) 93 CASE ('readnf_hz') 94 print*,"readnf_hz used" 95 CALL dynetat0_hz(f_ps,f_phis,f_theta_rhodz,f_u,f_q) 87 CALL etat0_dcmip4(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 96 88 CASE DEFAULT 97 89 PRINT*, 'Bad selector for variable etat0 <',etat0_type, & … … 114 106 115 107 SUBROUTINE etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q) 108 USE theta2theta_rhodz_mod 116 109 IMPLICIT NONE 117 110 TYPE(t_field),POINTER :: f_ps(:) … … 119 112 TYPE(t_field),POINTER :: f_phis(:) 120 113 TYPE(t_field),POINTER :: f_theta_rhodz(:) 114 TYPE(t_field),POINTER :: f_temp(:) 121 115 TYPE(t_field),POINTER :: f_u(:) 122 116 TYPE(t_field),POINTER :: f_q(:) … … 126 120 REAL(rstd),POINTER :: phis(:) 127 121 REAL(rstd),POINTER :: theta_rhodz(:,:) 122 REAL(rstd),POINTER :: temp(:,:) 128 123 REAL(rstd),POINTER :: u(:,:) 129 124 REAL(rstd),POINTER :: q(:,:,:) … … 138 133 phis=f_phis(ind) 139 134 theta_rhodz=f_theta_rhodz(ind) 135 temp=f_temp(ind) 140 136 u=f_u(ind) 141 137 q=f_q(ind) 142 CALL compute_etat0_collocated(ps,mass, phis, theta_rhodz, u, q) 138 139 IF( TRIM(etat0_type)=='williamson91.6' ) THEN 140 CALL compute_etat0_collocated(ps,mass, phis, theta_rhodz, u, q) 141 ELSE 142 CALL compute_etat0_collocated(ps,mass, phis, temp, u, q) 143 ENDIF 143 144 ENDDO 145 146 IF( TRIM(etat0_type)/='williamson91.6' ) CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz) 147 148 144 149 END SUBROUTINE etat0_collocated 145 150 146 SUBROUTINE compute_etat0_collocated(ps,mass, phis, theta_rhodz, u, q) 147 USE theta2theta_rhodz_mod 151 SUBROUTINE compute_etat0_collocated(ps,mass, phis, temp_i, u, q) 148 152 USE wind_mod 149 153 USE etat0_jablonowsky06_mod, ONLY : compute_jablonowsky06 => compute_etat0 … … 154 158 REAL(rstd),INTENT(INOUT) :: mass(iim*jjm,llm) 155 159 REAL(rstd),INTENT(OUT) :: phis(iim*jjm) 156 REAL(rstd),INTENT(OUT) :: t heta_rhodz(iim*jjm,llm)160 REAL(rstd),INTENT(OUT) :: temp_i(iim*jjm,llm) 157 161 REAL(rstd),INTENT(OUT) :: u(3*iim*jjm,llm) 158 162 REAL(rstd),INTENT(OUT) :: q(iim*jjm,llm,nqtot) 159 163 160 REAL(rstd) :: temp_i(iim*jjm,llm) 164 REAL(rstd) :: lon_i(iim*jjm) 165 REAL(rstd) :: lat_i(iim*jjm) 161 166 REAL(rstd) :: ulon_i(iim*jjm,llm) 162 167 REAL(rstd) :: ulat_i(iim*jjm,llm) 163 168 169 REAL(rstd) :: lon_e(3*iim*jjm) 170 REAL(rstd) :: lat_e(3*iim*jjm) 164 171 REAL(rstd) :: ps_e(3*iim*jjm) 165 172 REAL(rstd) :: mass_e(3*iim*jjm,llm) … … 183 190 CALL compute_dcmip5(3*iim*jjm,lon_e,lat_e, phis_e, ps_e, temp_e, ulon_e, ulat_e, q_e) 184 191 CASE('williamson91.6') 185 CALL compute_w91_6(iim*jjm,lon_i,lat_i, phis, mass(:,1), t heta_rhodz(:,1), ulon_i(:,1), ulat_i(:,1))192 CALL compute_w91_6(iim*jjm,lon_i,lat_i, phis, mass(:,1), temp_i(:,1), ulon_i(:,1), ulat_i(:,1)) 186 193 CALL compute_w91_6(3*iim*jjm,lon_e,lat_e, phis_e, mass_e(:,1), temp_e(:,1), ulon_e(:,1), ulat_e(:,1)) 187 194 END SELECT 188 195 189 SELECT CASE (TRIM(etat0_type))190 CASE('williamson91.6')191 ! Do nothing192 CASE DEFAULT193 CALL compute_temperature2theta_rhodz(ps,temp_i,theta_rhodz,0)194 END SELECT195 196 196 CALL compute_wind_perp_from_lonlat_compound(ulon_e, ulat_e, u) 197 197 -
codes/icosagcm/trunk/src/etat0_academic.f90
r286 r295 134 134 135 135 136 !$OMP BARRIER 136 137 CALL compute_pression(ps,p,1) 138 !$OMP BARRIER 137 139 CALL compute_exner(ps,p,pks,pk,1) 140 !$OMP BARRIER 138 141 CALL compute_geopotential(phis,pks,pk,theta,phi,1) 139 142 -
codes/icosagcm/trunk/src/etat0_dcmip2.f90
r286 r295 14 14 SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 15 15 USE icosa 16 USE theta2theta_rhodz_mod 16 17 IMPLICIT NONE 17 18 TYPE(t_field),POINTER :: f_ps(:) … … 20 21 TYPE(t_field),POINTER :: f_u(:) 21 22 TYPE(t_field),POINTER :: f_q(:) 22 23 24 TYPE(t_field),POINTER,SAVE :: f_temp(:) 23 25 REAL(rstd),POINTER :: ps(:) 24 26 REAL(rstd),POINTER :: phis(:) 25 27 REAL(rstd),POINTER :: u(:,:) 26 REAL(rstd),POINTER :: theta_rhodz(:,:)28 REAL(rstd),POINTER :: Temp(:,:) 27 29 REAL(rstd),POINTER :: q(:,:,:) 28 30 … … 45 47 PRINT *, 'Orographic gravity-wave test case :', TRIM(etat0_type) 46 48 49 CALL allocate_field(f_temp,field_t,type_real,llm,name='temp') 50 47 51 DO ind=1,ndomain 48 52 IF (.NOT. assigned_domain(ind)) CYCLE … … 53 57 phis=f_phis(ind) 54 58 u=f_u(ind) 55 theta_rhodz=f_theta_rhodz(ind)56 59 q=f_q(ind) 57 CALL compute_etat0_DCMIP2(icase,ps,phis,u,theta_rhodz,q) 60 temp=f_temp(ind) 61 CALL compute_etat0_DCMIP2(icase,ps,phis,u,Temp,q) 58 62 ENDDO 63 64 CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz) 59 65 66 CALL deallocate_field(f_temp) 67 60 68 END SUBROUTINE etat0 61 69 62 SUBROUTINE compute_etat0_DCMIP2(icase, ps, phis, u, t heta_rhodz,q)70 SUBROUTINE compute_etat0_DCMIP2(icase, ps, phis, u, temp,q) 63 71 USE icosa 64 72 USE disvert_mod, ONLY : ap,bp … … 71 79 REAL(rstd), INTENT(OUT) :: phis(iim*jjm) 72 80 REAL(rstd), INTENT(OUT) :: u(3*iim*jjm,llm) 73 REAL(rstd), INTENT(OUT) :: t heta_rhodz(iim*jjm,llm)81 REAL(rstd), INTENT(OUT) :: temp(iim*jjm,llm) 74 82 REAL(rstd), INTENT(OUT) :: q(iim*jjm,llm) 75 REAL(rstd) :: ulon(3*iim*jjm,llm), ulat(3*iim*jjm,llm) , temp(iim*jjm,llm)83 REAL(rstd) :: ulon(3*iim*jjm,llm), ulat(3*iim*jjm,llm) 76 84 77 85 INTEGER :: i,j,l,ij … … 90 98 END DO 91 99 END DO 92 CALL compute_temperature2theta_rhodz(ps,temp,theta_rhodz,1)93 100 94 101 ! Edges : ulon,ulat -
codes/icosagcm/trunk/src/etat0_dcmip3.f90
r286 r295 18 18 SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q) 19 19 USE icosa 20 USE theta2theta_rhodz_mod 20 21 IMPLICIT NONE 21 22 TYPE(t_field),POINTER :: f_ps(:) … … 24 25 TYPE(t_field),POINTER :: f_u(:) 25 26 TYPE(t_field),POINTER :: f_q(:) 27 TYPE(t_field),POINTER,SAVE :: f_temp(:) 26 28 27 29 REAL(rstd),POINTER :: ps(:) 28 30 REAL(rstd),POINTER :: phis(:) 29 31 REAL(rstd),POINTER :: u(:,:) 30 REAL(rstd),POINTER :: theta_rhodz(:,:)32 REAL(rstd),POINTER :: Temp(:,:) 31 33 REAL(rstd),POINTER :: q(:,:,:) 32 34 33 35 INTEGER :: ind 36 37 CALL allocate_field(f_temp,field_t,type_real,llm,name='temp') 34 38 35 39 DO ind=1,ndomain … … 41 45 phis=f_phis(ind) 42 46 u=f_u(ind) 43 theta_rhodz=f_theta_rhodz(ind)44 47 q=f_q(ind) 45 CALL compute_etat0_DCMIP3(ps,phis,u,theta_rhodz,q) 48 temp=f_temp(ind) 49 CALL compute_etat0_DCMIP3(ps,phis,u,Temp,q) 46 50 ENDDO 51 52 CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz) 53 CALL deallocate_field(f_temp) 47 54 48 55 END SUBROUTINE etat0 49 56 50 57 51 SUBROUTINE compute_etat0_DCMIP3(ps, phis, u, t heta_rhodz,q)58 SUBROUTINE compute_etat0_DCMIP3(ps, phis, u, temp,q) 52 59 USE icosa 53 60 USE pression_mod … … 68 75 REAL(rstd), INTENT(OUT) :: phis(iim*jjm) 69 76 REAL(rstd), INTENT(OUT) :: u(3*iim*jjm,llm) 70 REAL(rstd), INTENT(OUT) :: theta_rhodz(iim*jjm,llm)77 REAL(rstd), INTENT(OUT) :: Temp(iim*jjm,llm) 71 78 REAL(rstd), INTENT(OUT) :: q(iim*jjm,llm,nqtot) 72 79 73 80 REAL(rstd) :: Ts(iim*jjm) 74 81 REAL(rstd) :: s(iim*jjm) 75 REAL(rstd) :: T(iim*jjm,llm)76 82 REAL(rstd) :: p(iim*jjm,llm+1) 77 83 REAL(rstd) :: theta(iim*jjm,llm) … … 125 131 END DO 126 132 133 !$OMP BARRIER 127 134 CALL compute_pression(ps,p,0) 135 !$OMP BARRIER 128 136 129 137 DO l=1,llm … … 134 142 IF(use_dcmip_routine) THEN 135 143 CALL test3_gravity_wave(lon_i(ij),lat_i(ij),pp,dummy,0, & 136 dummy,dummy,dummy,T (ij,l),dummy,dummy,dummy,dummy)144 dummy,dummy,dummy,Temp(ij,l),dummy,dummy,dummy,dummy) 137 145 ELSE 138 146 pspsk=(pp/ps(ij))**kappa … … 142 150 thetap = dtheta *sin(2*Pi*zz/Lz) * s(ij) ! perturbation pot. temp. 143 151 theta(ij,l) = thetab + thetap 144 T (ij,l) = theta(ij,l)* ((pp/peq)**kappa)152 Temp(ij,l) = theta(ij,l)* ((pp/peq)**kappa) 145 153 ! T(ij,l) = Ts(ij)*pspsk / ( Ts(ij) / GG * ( pspsk-1) +1) ! background temp. 146 154 END IF … … 149 157 ENDDO 150 158 151 IF(use_dcmip_routine) THEN152 CALL compute_temperature2theta_rhodz(ps,T,theta_rhodz,0)153 ELSE154 CALL compute_temperature2theta_rhodz(ps,T,theta_rhodz,0)155 END IF159 ! IF(use_dcmip_routine) THEN 160 ! CALL compute_temperature2theta_rhodz(ps,T,theta_rhodz,0) 161 ! ELSE 162 ! CALL compute_temperature2theta_rhodz(ps,T,theta_rhodz,0) 163 ! END IF 156 164 157 165 pp=peq -
codes/icosagcm/trunk/src/exner.f90
r186 r295 22 22 INTEGER :: ind 23 23 24 !$OMP BARRIER 24 25 DO ind=1,ndomain 25 26 IF (.NOT. assigned_domain(ind)) CYCLE … … 32 33 CALL compute_exner(ps, p, pks, pk, 0) 33 34 ENDDO 35 !$OMP BARRIER 34 36 35 37 END SUBROUTINE exner … … 39 41 USE disvert_mod 40 42 USE pression_mod 43 USE omp_para 41 44 IMPLICIT NONE 42 45 REAL(rstd),INTENT(IN) :: ps(iim*jjm) … … 52 55 !! Compute Alpha and Beta 53 56 57 IF (is_omp_level_master) THEN 54 58 ! for llm layer 55 DO j=jj_begin-offset,jj_end+offset56 DO i=ii_begin-offset,ii_end+offset57 ij=(j-1)*iim+i58 alpha(ij,llm) = 0.59 beta (ij,llm) = 1./ (1+ 2*kappa)60 ENDDO61 ENDDO59 DO j=jj_begin-offset,jj_end+offset 60 DO i=ii_begin-offset,ii_end+offset 61 ij=(j-1)*iim+i 62 alpha(ij,llm) = 0. 63 beta (ij,llm) = 1./ (1+ 2*kappa) 64 ENDDO 65 ENDDO 62 66 63 67 ! for other layer 64 DO l = llm-1 , 2 , -1 68 DO l = llm-1 , 2 , -1 69 DO j=jj_begin-offset,jj_end+offset 70 DO i=ii_begin-offset,ii_end+offset 71 ij=(j-1)*iim+i 72 delta = p(ij,l)* (1+2*kappa) + p(ij,l+1)* ( beta(ij,l+1)- (1+2*kappa) ) 73 alpha(ij,l) = - p(ij,l+1) / delta * alpha(ij,l+1) 74 beta (ij,l) = p(ij,l ) / delta 75 ENDDO 76 ENDDO 77 ENDDO 78 79 !! Compute pk 80 81 ! for first layer 82 DO j=jj_begin-offset,jj_end+offset 83 DO i=ii_begin-offset,ii_end+offset 84 ij=(j-1)*iim+i 85 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 86 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / & 87 ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-(1.+2*kappa) )* p(ij,2) ) 88 ENDDO 89 ENDDO 90 91 ! for other layers 92 93 DO l = 2, llm 94 DO j=jj_begin-offset,jj_end+offset 95 DO i=ii_begin-offset,ii_end+offset 96 ij=(j-1)*iim+i 97 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 98 ENDDO 99 ENDDO 100 ENDDO 101 102 ENDIF 103 104 ELSE ! Simple calculation of Exner pressure based on centered average 105 ! surface : pks 106 IF (is_omp_level_master) THEN 107 108 DO j=jj_begin-offset,jj_end+offset 109 DO i=ii_begin-offset,ii_end+offset 110 ij=(j-1)*iim+i 111 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 112 ENDDO 113 ENDDO 114 115 ENDIF 116 117 ! 3D : pk 118 DO l = 1, llm 65 119 DO j=jj_begin-offset,jj_end+offset 66 120 DO i=ii_begin-offset,ii_end+offset 67 ij=(j-1)*iim+i 68 delta = p(ij,l)* (1+2*kappa) + p(ij,l+1)* ( beta(ij,l+1)- (1+2*kappa) ) 69 alpha(ij,l) = - p(ij,l+1) / delta * alpha(ij,l+1) 70 beta (ij,l) = p(ij,l ) / delta 121 ij=(j-1)*iim+i 122 pk(ij,l) = cpp * ((.5/preff)*(p(ij,l)+p(ij,l+1))) ** kappa 71 123 ENDDO 72 124 ENDDO 73 125 ENDDO 74 75 !! Compute pk76 77 ! for first layer78 DO j=jj_begin-offset,jj_end+offset79 DO i=ii_begin-offset,ii_end+offset80 ij=(j-1)*iim+i81 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa82 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / &83 ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-(1.+2*kappa) )* p(ij,2) )84 ENDDO85 ENDDO86 87 ! for other layers88 89 DO l = 2, llm90 DO j=jj_begin-offset,jj_end+offset91 DO i=ii_begin-offset,ii_end+offset92 ij=(j-1)*iim+i93 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)94 ENDDO95 ENDDO96 ENDDO97 98 ELSE ! Simple calculation of Exner pressure based on centered average99 ! surface : pks100 DO j=jj_begin-offset,jj_end+offset101 DO i=ii_begin-offset,ii_end+offset102 ij=(j-1)*iim+i103 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa104 ENDDO105 ENDDO106 126 107 ! 3D : pk108 DO l = 1, llm109 DO j=jj_begin-offset,jj_end+offset110 DO i=ii_begin-offset,ii_end+offset111 ij=(j-1)*iim+i112 pk(ij,l) = cpp * ((.5/preff)*(p(ij,l)+p(ij,l+1))) ** kappa113 ENDDO114 ENDDO115 ENDDO116 127 END IF 117 128 -
codes/icosagcm/trunk/src/field.f90
r266 r295 48 48 SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name) 49 49 USE domain_mod 50 USE omp_para 50 51 IMPLICIT NONE 51 52 TYPE(t_field),POINTER :: field(:) … … 64 65 65 66 DO ind=1,ndomain 66 IF (.NOT. assigned_domain(ind) ) CYCLE67 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 67 68 68 69 IF(PRESENT(name)) THEN … … 181 182 SUBROUTINE deallocate_field(field) 182 183 USE domain_mod 184 USE omp_para 183 185 IMPLICIT NONE 184 186 TYPE(t_field),POINTER :: field(:) … … 188 190 !$OMP BARRIER 189 191 DO ind=1,ndomain 190 IF (.NOT. assigned_domain(ind) ) CYCLE192 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 191 193 192 194 data_type=field(ind)%data_type -
codes/icosagcm/trunk/src/geometry.f90
r294 r295 166 166 USE vector 167 167 USE transfert_mod 168 USE omp_para 168 169 169 170 IMPLICIT NONE … … 186 187 187 188 DO ind=1,ndomain 188 IF (.NOT. assigned_domain(ind) ) CYCLE189 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 189 190 CALL swap_dimensions(ind) 190 191 CALL swap_geometry(ind) … … 212 213 USE vector 213 214 USE getin_mod 215 USE omp_para 214 216 IMPLICIT NONE 215 217 INTEGER :: nb_it=0 … … 226 228 227 229 DO ind=1,ndomain 228 IF (.NOT. assigned_domain(ind) ) CYCLE230 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 229 231 d=>domain(ind) 230 232 CALL swap_dimensions(ind) … … 241 243 242 244 DO ind=1,ndomain 243 IF (.NOT. assigned_domain(ind) ) CYCLE245 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master ) CYCLE 244 246 d=>domain(ind) 245 247 CALL swap_dimensions(ind) … … 271 273 sum=0 272 274 DO ind=1,ndomain 273 IF (.NOT. assigned_domain(ind) ) CYCLE275 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master ) CYCLE 274 276 CALL swap_dimensions(ind) 275 277 CALL swap_geometry(ind) … … 311 313 USE transfert_mod 312 314 USE getin_mod 315 USE omp_para 313 316 IMPLICIT NONE 314 317 … … 330 333 331 334 DO ind=1,ndomain 332 IF (.NOT. assigned_domain(ind) ) CYCLE335 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master ) CYCLE 333 336 d=>domain(ind) 334 337 CALL swap_dimensions(ind) … … 559 562 CALL transfert_request(geom%centroid,req_i1) 560 563 561 CALL surf_triangle(d%xyz(:,ii_begin,jj_begin),d%xyz(:,ii_begin,jj_end),d%xyz(:,ii_end,jj_begin),S)564 ! CALL surf_triangle(d%xyz(:,ii_begin,jj_begin),d%xyz(:,ii_begin,jj_end),d%xyz(:,ii_end,jj_begin),S) 562 565 563 566 END SUBROUTINE set_geometry -
codes/icosagcm/trunk/src/geopotential_mod.f90
r186 r295 35 35 SUBROUTINE compute_geopotential(phis,pks,pk,theta,phi,offset) 36 36 USE icosa 37 USE omp_para 37 38 IMPLICIT NONE 38 39 REAL(rstd),INTENT(IN) :: phis(iim*jjm) … … 51 52 52 53 ! for first layer 53 DO j=jj_begin-offset,jj_end+offset 54 DO i=ii_begin-offset,ii_end+offset 55 ij=(j-1)*iim+i 56 phi( ij,1 ) = phis( ij ) + theta(ij,1) * ( pks(ij) - pk(ij,1) ) 57 ENDDO 58 ENDDO 59 60 ! for other layers 61 DO l = 2, llm 54 55 ! flush pks, pk thetha, phis 56 !$OMP BARRIER 57 IF(is_omp_level_master) THEN 62 58 DO j=jj_begin-offset,jj_end+offset 63 59 DO i=ii_begin-offset,ii_end+offset 64 60 ij=(j-1)*iim+i 65 phi(ij,l) = phi(ij,l-1) + 0.5 * ( theta(ij,l) + theta(ij,l-1) ) & 66 * ( pk(ij,l-1) - pk(ij,l) ) 61 phi( ij,1 ) = phis( ij ) + theta(ij,1) * ( pks(ij) - pk(ij,1) ) 67 62 ENDDO 68 63 ENDDO 69 ENDDO 64 65 ! for other layers 66 DO l = 2, llm 67 DO j=jj_begin-offset,jj_end+offset 68 DO i=ii_begin-offset,ii_end+offset 69 ij=(j-1)*iim+i 70 phi(ij,l) = phi(ij,l-1) + 0.5 * ( theta(ij,l) + theta(ij,l-1) ) & 71 * ( pk(ij,l-1) - pk(ij,l) ) 72 ENDDO 73 ENDDO 74 ENDDO 75 ENDIF 76 ! flush phi 77 !$OMP BARRIER 70 78 71 79 END SUBROUTINE compute_geopotential -
codes/icosagcm/trunk/src/icosa_gcm.f90
r280 r295 19 19 CALL xios_init 20 20 CALL init_earth_const 21 CALL init_grid_param(is_mpi_ root)22 CALL init_omp_para 21 CALL init_grid_param(is_mpi_master) 22 CALL init_omp_para(is_mpi_master) 23 23 CALL compute_metric 24 24 CALL compute_domain … … 28 28 29 29 !$OMP PARALLEL 30 CALL switch_omp_no_distrib_level 30 31 CALL compute_geometry 31 32 CALL check_total_area … … 43 44 44 45 CALL timeloop 45 46 CALL switch_omp_no_distrib_level 46 47 !$OMP END PARALLEL 47 48 -
codes/icosagcm/trunk/src/kinetic.f90
r186 r295 30 30 SUBROUTINE compute_kinetic(ue, Ki) 31 31 USE icosa 32 USE omp_para 32 33 IMPLICIT NONE 33 34 REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm) … … 35 36 INTEGER :: i,j,ij,l 36 37 37 DO l= 1,llm38 DO l=ll_begin,ll_end 38 39 DO j=jj_begin,jj_end 39 40 DO i=ii_begin,ii_end -
codes/icosagcm/trunk/src/omega.f90
r186 r295 23 23 END SUBROUTINE W_omega 24 24 25 26 25 27 SUBROUTINE compute_omega(ps,u, w) 26 28 USE disvert_mod, ONLY : ap,bp 29 USE omp_para 30 IMPLICIT NONE 27 31 REAL(rstd),INTENT(IN) :: u(iim*3*jjm,llm), ps(iim*jjm) 28 32 REAL(rstd),INTENT(OUT):: w(iim*jjm,llm) … … 30 34 REAL(rstd):: p(iim*jjm,llm+1), rhodz(iim*jjm,llm), Fe(iim*3*jjm,llm) 31 35 REAL(rstd):: ugradps 32 DO l = 1, llm+1 33 DO j=jj_begin-1,jj_end+1 34 DO i=ii_begin-1,ii_end+1 35 ij=(j-1)*iim+i 36 p(ij,l) = ap(l) + bp(l) * ps(ij) 37 ENDDO 38 ENDDO 39 ENDDO 36 37 INTEGER :: i,j,l,ij 38 39 !$OMP BARRIER 40 IF (is_omp_level_master) THEN 41 DO l = 1, llm+1 42 DO j=jj_begin-1,jj_end+1 43 DO i=ii_begin-1,ii_end+1 44 ij=(j-1)*iim+i 45 p(ij,l) = ap(l) + bp(l) * ps(ij) 46 ENDDO 47 ENDDO 48 ENDDO 40 49 41 50 !!! Compute mass 42 DO l = 1, llm43 DO j=jj_begin-1,jj_end+144 DO i=ii_begin-1,ii_end+145 ij=(j-1)*iim+i46 rhodz(ij,l) = ( p(ij,l) - p(ij,l+1) ) / g47 ENDDO48 ENDDO49 ENDDO51 DO l = 1, llm 52 DO j=jj_begin-1,jj_end+1 53 DO i=ii_begin-1,ii_end+1 54 ij=(j-1)*iim+i 55 rhodz(ij,l) = ( p(ij,l) - p(ij,l+1) ) / g 56 ENDDO 57 ENDDO 58 ENDDO 50 59 51 60 !!! Compute mass flux 52 DO l = 1, llm53 DO j=jj_begin-1,jj_end+154 DO i=ii_begin-1,ii_end+155 ij=(j-1)*iim+i56 Fe(ij+u_right,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_right,l))*u(ij+u_right,l)*le(ij+u_right)57 Fe(ij+u_lup,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_lup,l))*u(ij+u_lup,l)*le(ij+u_lup)58 Fe(ij+u_ldown,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_ldown,l))*u(ij+u_ldown,l)*le(ij+u_ldown)59 ENDDO60 ENDDO61 ENDDO61 DO l = 1, llm 62 DO j=jj_begin-1,jj_end+1 63 DO i=ii_begin-1,ii_end+1 64 ij=(j-1)*iim+i 65 Fe(ij+u_right,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_right,l))*u(ij+u_right,l)*le(ij+u_right) 66 Fe(ij+u_lup,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_lup,l))*u(ij+u_lup,l)*le(ij+u_lup) 67 Fe(ij+u_ldown,l)=0.5*(rhodz(ij,l)+rhodz(ij+t_ldown,l))*u(ij+u_ldown,l)*le(ij+u_ldown) 68 ENDDO 69 ENDDO 70 ENDDO 62 71 63 72 !!! mass flux convergence computation 64 73 65 74 ! horizontal convergence 66 DO l = 1, llm67 DO j=jj_begin,jj_end68 DO i=ii_begin,ii_end69 ij=(j-1)*iim+i70 ! convm = +div(mass flux), sign convention as in Ringler et al. 2012, eq. 2171 convm(ij,l)= 1./Ai(ij)*(ne(ij,right)*Fe(ij+u_right,l) + &72 ne(ij,rup)*Fe(ij+u_rup,l) + &73 ne(ij,lup)*Fe(ij+u_lup,l) + &74 ne(ij,left)*Fe(ij+u_left,l) + &75 ne(ij,ldown)*Fe(ij+u_ldown,l) + &76 ne(ij,rdown)*Fe(ij+u_rdown,l))77 ENDDO78 ENDDO79 ENDDO75 DO l = 1, llm 76 DO j=jj_begin,jj_end 77 DO i=ii_begin,ii_end 78 ij=(j-1)*iim+i 79 ! convm = +div(mass flux), sign convention as in Ringler et al. 2012, eq. 21 80 convm(ij,l)= 1./Ai(ij)*(ne(ij,right)*Fe(ij+u_right,l) + & 81 ne(ij,rup)*Fe(ij+u_rup,l) + & 82 ne(ij,lup)*Fe(ij+u_lup,l) + & 83 ne(ij,left)*Fe(ij+u_left,l) + & 84 ne(ij,ldown)*Fe(ij+u_ldown,l) + & 85 ne(ij,rdown)*Fe(ij+u_rdown,l)) 86 ENDDO 87 ENDDO 88 ENDDO 80 89 81 ! vertical integration from up to down82 DO l = llm-1, 1, -183 DO j=jj_begin,jj_end84 DO i=ii_begin,ii_end85 ij=(j-1)*iim+i86 convm(ij,l) = convm(ij,l) + convm(ij,l+1)87 ENDDO88 ENDDO89 ENDDO90 convm(:,llm+1)=0.90 ! vertical integration from up to down 91 DO l = llm-1, 1, -1 92 DO j=jj_begin,jj_end 93 DO i=ii_begin,ii_end 94 ij=(j-1)*iim+i 95 convm(ij,l) = convm(ij,l) + convm(ij,l+1) 96 ENDDO 97 ENDDO 98 ENDDO 99 convm(:,llm+1)=0. 91 100 92 101 !!! Compute dps … … 125 134 ! -grad ps : ( ne(ij,ldown)*ps(ij,l) + ne(ij+t_ldown,rup)*ps(ij+t_ldown,l) ) ) / de(ij+u_ldown) 126 135 127 DO l = 1,llm 128 DO j=jj_begin,jj_end 129 DO i=ii_begin,ii_end 130 toto = 1 136 DO l = 1,llm 137 DO j=jj_begin,jj_end 138 DO i=ii_begin,ii_end 131 139 ij=(j-1)*iim+i 132 140 ugradps = & … … 140 148 w( ij, l) = ugradps - .5*(convm( ij,l+1)+convm(ij,l)) 141 149 ENDDO 142 ENDDO 143 ENDDO 150 ENDDO 151 ENDDO 152 ENDIF 153 !$OMP BARRIER 144 154 145 155 END SUBROUTINE compute_omega -
codes/icosagcm/trunk/src/omp_para.F90
r186 r295 5 5 !$OMP THREADPRIVATE(omp_rank) 6 6 7 LOGICAL,SAVE :: omp_first8 LOGICAL,SAVE :: omp_last9 LOGICAL,SAVE :: omp_master10 !$OMP THREADPRIVATE( omp_first, omp_last,omp_master)7 LOGICAL,SAVE :: is_omp_first_level 8 LOGICAL,SAVE :: is_omp_last_level 9 LOGICAL,SAVE :: is_omp_master 10 !$OMP THREADPRIVATE(is_omp_first_level, is_omp_last_level,is_omp_master) 11 11 12 12 INTEGER,SAVE :: ll_begin … … 17 17 !$OMP THREADPRIVATE(ll_begin,ll_beginp1,ll_end,ll_endm1,ll_endp1) 18 18 LOGICAL,SAVE :: using_openmp 19 19 20 INTEGER,SAVE :: omp_domain_size 21 INTEGER,SAVE :: omp_domain_rank 22 INTEGER,SAVE :: omp_level_size 23 INTEGER,SAVE :: omp_level_rank 24 !$OMP THREADPRIVATE( omp_domain_size, omp_level_size,omp_domain_rank,omp_level_rank) 25 LOGICAL,SAVE :: is_omp_domain_master 26 LOGICAL,SAVE :: is_omp_level_master 27 !$OMP THREADPRIVATE(is_omp_domain_master,is_omp_level_master ) 28 20 29 LOGICAL,PARAMETER :: omp_by_domain=.TRUE. 30 LOGICAL,SAVE :: is_master 31 !$OMP THREADPRIVATE(is_master) 32 33 34 LOGICAL,SAVE :: is_omp_first_level_full 35 LOGICAL,SAVE :: is_omp_last_level_full 36 INTEGER,SAVE :: ll_begin_full 37 INTEGER,SAVE :: ll_beginp1_full 38 INTEGER,SAVE :: ll_end_full 39 INTEGER,SAVE :: ll_endm1_full 40 INTEGER,SAVE :: ll_endp1_full 41 !$OMP THREADPRIVATE(is_omp_first_level_full,is_omp_last_level_full) 42 !$OMP THREADPRIVATE( ll_begin_full, ll_beginp1_full, ll_end_full, ll_endm1_full, ll_endp1_full) 43 PRIVATE :: is_omp_first_level_full,is_omp_last_level_full 44 PRIVATE :: ll_begin_full, ll_beginp1_full, ll_end_full, ll_endm1_full, ll_endp1_full 45 46 47 LOGICAL,SAVE :: is_omp_first_level_distrib 48 LOGICAL,SAVE :: is_omp_last_level_distrib 49 INTEGER,SAVE :: ll_begin_distrib 50 INTEGER,SAVE :: ll_beginp1_distrib 51 INTEGER,SAVE :: ll_end_distrib 52 INTEGER,SAVE :: ll_endm1_distrib 53 INTEGER,SAVE :: ll_endp1_distrib 54 !$OMP THREADPRIVATE(is_omp_first_level_distrib,is_omp_last_level_distrib) 55 !$OMP THREADPRIVATE( ll_begin_distrib, ll_beginp1_distrib, ll_end_distrib, ll_endm1_distrib, ll_endp1_distrib) 56 57 PRIVATE :: is_omp_first_level_distrib,is_omp_last_level_distrib 58 PRIVATE :: ll_begin_distrib, ll_beginp1_distrib, ll_end_distrib, ll_endm1_distrib, ll_endp1_distrib 59 21 60 22 61 CONTAINS 23 62 24 63 25 SUBROUTINE init_omp_para 64 SUBROUTINE init_omp_para(is_mpi_master) 26 65 USE grid_param 66 USE getin_mod 27 67 #ifdef CPP_USING_OMP 28 68 USE omp_lib 29 69 #endif 30 70 IMPLICIT NONE 71 LOGICAL, INTENT(IN) :: is_mpi_master 31 72 INTEGER :: ll_nb,i 32 73 … … 49 90 omp_rank=OMP_GET_THREAD_NUM() 50 91 #endif 51 52 IF (omp_by_domain) THEN 53 omp_first=.TRUE. 54 omp_last=.TRUE. 55 IF (omp_rank==0) THEN 56 omp_master=.TRUE. 57 ELSE 58 omp_master=.FALSE. 59 ENDIF 60 61 ll_begin=1 62 ll_beginp1=2 63 ll_end=llm 64 ll_endm1=llm-1 65 ll_endp1=llm+1 66 67 ELSE 68 69 omp_first=.FALSE. 70 omp_last=.FALSE. 71 omp_master=.FALSE. 72 73 IF (omp_rank==0) THEN 74 omp_first=.TRUE. 75 omp_master=.TRUE. 76 ENDIF 77 78 IF (omp_rank==omp_size-1) omp_last=.TRUE. 79 80 ll_end=0 81 DO i=0,omp_rank 82 ll_begin=ll_end+1 83 ll_nb=llm/omp_size 84 IF (MOD(llm,omp_size)>i) ll_nb=ll_nb+1 85 ll_end=ll_begin+ll_nb-1 86 ENDDO 87 88 ll_beginp1=ll_begin 89 ll_endp1=ll_end 90 ll_endm1=ll_end 91 92 IF (omp_first) ll_beginp1=ll_begin+1 93 IF (omp_last) ll_endp1=ll_endp1+1 94 IF (omp_last) ll_endm1=ll_endm1-1 95 92 93 is_omp_master=.FALSE. 94 is_master=.FALSE. 95 96 IF (omp_rank==0) THEN 97 is_omp_master=.TRUE. 98 IF (is_mpi_master) is_master=.TRUE. 96 99 ENDIF 100 101 omp_level_size=1 102 CALL getin("omp_level_size",omp_level_size) 103 IF (MOD(omp_size,omp_level_size)/=0) THEN 104 IF (is_mpi_master) PRINT*,"omp_size /= omp_level_size x omp_domain_size => disable omp threads on vertical layers" 105 omp_level_size=1 106 ENDIF 107 omp_domain_size=omp_size/omp_level_size 108 omp_domain_rank = omp_rank / omp_level_size 109 omp_level_rank = MOD(omp_rank, omp_level_size) 110 111 IF (is_mpi_master) PRINT*,"omp_domain_size",omp_domain_size,"omp_domain_rank", omp_domain_rank 112 IF (is_mpi_master) PRINT*,"omp_level_size",omp_level_size,"omp_level_rank", omp_level_rank 113 114 is_omp_first_level=.FALSE. 115 is_omp_last_level= .FALSE. 116 is_omp_domain_master=.FALSE. 117 is_omp_level_master=.FALSE. 118 119 IF (omp_domain_rank==0) is_omp_domain_master = .TRUE. 120 IF (omp_level_rank==0) is_omp_level_master = .TRUE. 121 IF (omp_level_rank==0) is_omp_first_level=.TRUE. 122 123 IF (omp_level_rank==omp_level_size-1) is_omp_last_level=.TRUE. 124 125 ll_end=0 126 DO i=0,omp_level_rank 127 ll_begin=ll_end+1 128 ll_nb=llm/omp_level_size 129 IF (MOD(llm,omp_level_size)>i) ll_nb=ll_nb+1 130 ll_end=ll_begin+ll_nb-1 131 ENDDO 132 133 ll_beginp1=ll_begin 134 ll_endp1=ll_end 135 ll_endm1=ll_end 136 137 IF (is_omp_first_level) ll_beginp1=ll_begin+1 138 IF (is_omp_last_level) ll_endp1=ll_endp1+1 139 IF (is_omp_last_level) ll_endm1=ll_endm1-1 140 141 142 143 is_omp_first_level_distrib = is_omp_first_level 144 is_omp_last_level_distrib = is_omp_last_level 145 ll_begin_distrib = ll_begin 146 ll_beginp1_distrib = ll_beginp1 147 ll_end_distrib = ll_end 148 ll_endm1_distrib = ll_endm1 149 ll_endp1_distrib = ll_endp1 150 151 is_omp_first_level_full = .TRUE. 152 is_omp_last_level_full = .TRUE. 153 ll_begin_full = 1 154 ll_beginp1_full = 2 155 ll_end_full = llm 156 ll_endm1_full = llm-1 157 ll_endp1_full = llm+1 158 97 159 !$OMP END PARALLEL 98 160 99 161 ELSE 100 162 omp_size=1 163 omp_level_size=1 164 omp_domain_size=1 101 165 omp_rank=0 102 omp_first=.TRUE. 103 omp_last=.TRUE. 104 omp_master=.TRUE. 166 omp_level_rank=0 167 omp_domain_rank=0 168 is_omp_first_level=.TRUE. 169 is_omp_last_level=.TRUE. 170 is_omp_master=.TRUE. 171 is_omp_domain_master=.TRUE. 172 is_omp_level_master=.TRUE. 105 173 ll_begin=1 106 174 ll_beginp1=2 … … 108 176 ll_endm1=llm-1 109 177 ll_endp1=llm+1 178 179 is_omp_first_level_distrib = is_omp_first_level 180 is_omp_last_level_distrib = is_omp_last_level 181 ll_begin_distrib = ll_begin 182 ll_beginp1_distrib = ll_beginp1 183 ll_end_distrib = ll_end 184 ll_endm1_distrib = ll_endm1 185 ll_endp1_distrib = ll_endp1 186 187 is_omp_first_level_full = .TRUE. 188 is_omp_last_level_full = .TRUE. 189 ll_begin_full = 1 190 ll_beginp1_full = 2 191 ll_end_full = llm 192 ll_endm1_full = llm-1 193 ll_endp1_full = llm+1 194 110 195 ENDIF 111 196 112 197 END SUBROUTINE init_omp_para 113 198 199 200 SUBROUTINE switch_omp_distrib_level 201 IMPLICIT NONE 202 is_omp_first_level = is_omp_first_level_distrib 203 is_omp_last_level = is_omp_last_level_distrib 204 ll_begin = ll_begin_distrib 205 ll_beginp1 = ll_beginp1_distrib 206 ll_end = ll_end_distrib 207 ll_endm1 = ll_endm1_distrib 208 ll_endp1 = ll_endp1_distrib 209 210 END SUBROUTINE switch_omp_distrib_level 211 212 213 SUBROUTINE switch_omp_no_distrib_level 214 IMPLICIT NONE 215 216 is_omp_first_level = is_omp_first_level_full 217 is_omp_last_level = is_omp_last_level_full 218 ll_begin = ll_begin_full 219 ll_beginp1 = ll_beginp1_full 220 ll_end = ll_end_full 221 ll_endm1 = ll_endm1_full 222 ll_endp1 = ll_endp1_full 223 224 END SUBROUTINE switch_omp_no_distrib_level 225 226 114 227 FUNCTION omp_in_parallel() 115 228 #ifdef CPP_USING_OMP -
codes/icosagcm/trunk/src/physics.f90
r281 r295 10 10 TYPE(t_field),POINTER :: f_extra_physics_2D(:), f_extra_physics_3D(:) 11 11 TYPE(t_field),POINTER :: f_dulon(:), f_dulat(:) 12 TYPE(t_field),POINTER :: f_temp(:) 12 13 13 14 CHARACTER(LEN=255) :: physics_type … … 38 39 CALL allocate_field(f_dulon,field_t,type_real,llm, name='dulon') 39 40 CALL allocate_field(f_dulat,field_t,type_real,llm, name='dulat') 41 CALL allocate_field(f_temp,field_t,type_real,llm, name='temp') 40 42 CALL init_pack_before ! Compute physics_inout%ngrid and offsets used by pack/unpack 41 43 CALL init_physics_dcmip … … 102 104 USE physics_interface_mod 103 105 USE physics_dcmip_mod, ONLY : full_physics_dcmip => full_physics 106 USE theta2theta_rhodz_mod 104 107 USE mpipara 105 108 IMPLICIT NONE … … 111 114 REAL(rstd),POINTER :: phis(:) 112 115 REAL(rstd),POINTER :: ps(:) 116 REAL(rstd),POINTER :: temp(:,:) 113 117 REAL(rstd),POINTER :: theta_rhodz(:,:) 114 118 REAL(rstd),POINTER :: ue(:,:) … … 118 122 INTEGER :: it, ind 119 123 124 CALL theta_rhodz2temperature(f_ps,f_theta_rhodz,f_temp) 125 120 126 DO ind=1,ndomain 121 127 IF (.NOT. assigned_domain(ind)) CYCLE … … 124 130 phis=f_phis(ind) 125 131 ps=f_ps(ind) 126 t heta_rhodz=f_theta_rhodz(ind)132 temp=f_temp(ind) 127 133 ue=f_ue(ind) 128 134 q=f_q(ind) 129 CALL pack_physics(pack_info(ind), phis, ps, t heta_rhodz, ue, q)135 CALL pack_physics(pack_info(ind), phis, ps, temp, ue, q) 130 136 END DO 131 137 … … 134 140 CALL full_physics_dcmip 135 141 CASE DEFAULT 136 IF(is_mpi_ root) PRINT *,'Internal error : illegal value of phys_type', phys_type142 IF(is_mpi_master) PRINT *,'Internal error : illegal value of phys_type', phys_type 137 143 STOP 138 144 END SELECT … … 143 149 CALL swap_geometry(ind) 144 150 ps=f_ps(ind) 145 t heta_rhodz=f_theta_rhodz(ind)151 temp=f_temp(ind) 146 152 q=f_q(ind) 147 153 dulon=f_dulon(ind) 148 154 dulat=f_dulat(ind) 149 CALL unpack_physics(pack_info(ind), ps, t heta_rhodz, q, dulon, dulat)155 CALL unpack_physics(pack_info(ind), ps, temp, q, dulon, dulat) 150 156 END DO 157 CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz) 151 158 152 159 ! Transfer dulon, dulat … … 166 173 END SUBROUTINE physics_column 167 174 168 SUBROUTINE pack_physics(info, phis, ps, t heta_rhodz, ue, q)175 SUBROUTINE pack_physics(info, phis, ps, temp, ue, q) 169 176 USE icosa 170 177 USE wind_mod … … 176 183 REAL(rstd) :: phis(iim*jjm) 177 184 REAL(rstd) :: ps(iim*jjm) 178 REAL(rstd) :: t heta_rhodz(iim*jjm,llm)185 REAL(rstd) :: temp(iim*jjm,llm) 179 186 REAL(rstd) :: ue(3*iim*jjm,llm) 180 187 REAL(rstd) :: q(iim*jjm,llm,nqtot) 181 188 182 189 REAL(rstd) :: p(iim*jjm,llm+1) 183 REAL(rstd) :: Temp(iim*jjm,llm)184 190 REAL(rstd) :: uc(iim*jjm,3,llm) 185 191 REAL(rstd) :: ulon(iim*jjm,llm) 186 192 REAL(rstd) :: ulat(iim*jjm,llm) 187 193 194 !$OMP BARRIER 188 195 CALL compute_pression(ps,p,0) 189 CALL compute_theta_rhodz2temperature(ps,theta_rhodz,Temp,0) 196 !$OMP BARRIER 190 197 CALL compute_wind_centered(ue,uc) 191 198 CALL compute_wind_centered_lonlat_compound(uc, ulon, ulat) … … 199 206 END SUBROUTINE pack_physics 200 207 201 SUBROUTINE unpack_physics(info, ps,t heta_rhodz, q, dulon, dulat)208 SUBROUTINE unpack_physics(info, ps,temp, q, dulon, dulat) 202 209 USE icosa 203 210 USE physics_interface_mod … … 206 213 TYPE(t_pack_info) :: info 207 214 REAL(rstd) :: ps(iim*jjm) 208 REAL(rstd) :: theta_rhodz(iim*jjm,llm) 209 REAL(rstd) :: Temp(iim*jjm,llm) 215 REAL(rstd) :: temp(iim*jjm,llm) 210 216 REAL(rstd) :: q(iim*jjm,llm,nqtot) 211 217 REAL(rstd) :: dulon(iim*jjm,llm) … … 221 227 q = q + physics_inout%dt_phys * dq 222 228 Temp = Temp + physics_inout%dt_phys * dTemp 223 CALL compute_temperature2theta_rhodz(ps,Temp,theta_rhodz,0)229 ! CALL compute_temperature2theta_rhodz(ps,Temp,theta_rhodz,0) 224 230 END SUBROUTINE unpack_physics 225 231 -
codes/icosagcm/trunk/src/pression.f90
r186 r295 13 13 INTEGER :: ind 14 14 15 !$OMP BARRIER 15 16 DO ind=1,ndomain 16 17 IF (.NOT. assigned_domain(ind)) CYCLE … … 21 22 CALL compute_pression(ps, p,0) 22 23 ENDDO 24 !$OMP BARRIER 23 25 24 26 END SUBROUTINE pression … … 27 29 USE icosa 28 30 USE disvert_mod 31 USE omp_para 29 32 IMPLICIT NONE 30 33 REAL(rstd),INTENT(IN) :: ps(iim*jjm) … … 34 37 35 38 IF(ap_bp_present) THEN 36 DO l = 1, llm+1 37 DO j=jj_begin-offset,jj_end+offset 38 DO i=ii_begin-offset,ii_end+offset 39 ij=(j-1)*iim+i 40 p(ij,l) = ap(l) + bp(l) * ps(ij) 39 DO l = ll_begin, ll_endp1 40 ! DO l = 1, llm + 1 41 DO j=jj_begin-offset,jj_end+offset 42 DO i=ii_begin-offset,ii_end+offset 43 ij=(j-1)*iim+i 44 p(ij,l) = ap(l) + bp(l) * ps(ij) 45 ENDDO 41 46 ENDDO 42 47 ENDDO 43 ENDDO44 48 END IF 49 45 50 END SUBROUTINE compute_pression 46 51 -
codes/icosagcm/trunk/src/theta_rhodz.f90
r186 r295 1 1 MODULE theta2theta_rhodz_mod 2 USE field_mod 3 4 TYPE(t_field), POINTER, SAVE :: f_p(:) 5 TYPE(t_field), POINTER, SAVE :: f_pks(:) 6 TYPE(t_field), POINTER, SAVE :: f_pk(:) 7 8 PRIVATE :: f_p,f_pk,f_pks 2 9 3 10 CONTAINS 4 11 12 SUBROUTINE init_theta2theta_rhodz 13 USE icosa 14 USE field_mod 15 IMPLICIT NONE 16 CALL allocate_field(f_p,field_t,type_real,llm+1,name='p') 17 CALL allocate_field(f_pk,field_t,type_real,llm,name='pk') 18 CALL allocate_field(f_pks,field_t,type_real,name='pks') 19 20 END SUBROUTINE init_theta2theta_rhodz 21 22 23 5 24 SUBROUTINE theta_rhodz2theta(f_ps,f_theta_rhodz,f_theta) 6 25 USE icosa … … 15 34 INTEGER :: ind 16 35 36 !$OMP BARRIER 17 37 DO ind=1,ndomain 18 38 IF (.NOT. assigned_domain(ind)) CYCLE … … 24 44 CALL compute_theta_rhodz2theta(ps, theta_rhodz,theta,0) 25 45 ENDDO 46 !$OMP BARRIER 26 47 27 48 END SUBROUTINE theta_rhodz2theta … … 29 50 SUBROUTINE theta_rhodz2temperature(f_ps,f_theta_rhodz,f_temp) 30 51 USE icosa 52 USE pression_mod 53 USE exner_mod 31 54 IMPLICIT NONE 32 55 TYPE(t_field), POINTER :: f_ps(:) … … 37 60 REAL(rstd), POINTER :: theta_rhodz(:,:) 38 61 REAL(rstd), POINTER :: temp(:,:) 39 INTEGER :: ind 40 41 DO ind=1,ndomain 42 IF (.NOT. assigned_domain(ind)) CYCLE 43 CALL swap_dimensions(ind) 44 CALL swap_geometry(ind) 45 ps=f_ps(ind) 62 REAL(rstd), POINTER :: p(:) 63 REAL(rstd), POINTER :: pk(:,:) 64 REAL(rstd), POINTER :: pks(:,:) 65 INTEGER :: ind 66 67 DO ind=1,ndomain 68 IF (.NOT. assigned_domain(ind)) CYCLE 69 CALL swap_dimensions(ind) 70 CALL swap_geometry(ind) 71 ps=f_ps(ind) 72 p=f_p(ind) 73 pks=f_pks(ind) 74 pk=f_pk(ind) 46 75 theta_rhodz=f_theta_rhodz(ind) 47 76 temp=f_temp(ind) 48 CALL compute_theta_rhodz2temperature(ps, theta_rhodz,temp,0) 49 ENDDO 77 78 !$OMP BARRIER 79 CALL compute_pression(ps,p,0) 80 !$OMP BARRIER 81 CALL compute_exner(ps,p,pks,pk,0) 82 !$OMP BARRIER 83 CALL compute_theta_rhodz2temperature(p, pk, theta_rhodz,temp,0) 84 ENDDO 85 !$OMP BARRIER 50 86 51 87 END SUBROUTINE theta_rhodz2temperature 88 89 SUBROUTINE temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz) 90 USE icosa 91 USE pression_mod 92 USE exner_mod 93 IMPLICIT NONE 94 TYPE(t_field), POINTER :: f_ps(:) 95 TYPE(t_field), POINTER :: f_theta_rhodz(:) 96 TYPE(t_field), POINTER :: f_temp(:) 97 98 REAL(rstd), POINTER :: ps(:) 99 REAL(rstd), POINTER :: theta_rhodz(:,:) 100 REAL(rstd), POINTER :: temp(:,:) 101 REAL(rstd), POINTER :: p(:) 102 REAL(rstd), POINTER :: pk(:,:) 103 REAL(rstd), POINTER :: pks(:,:) 104 INTEGER :: ind 105 106 DO ind=1,ndomain 107 IF (.NOT. assigned_domain(ind)) CYCLE 108 CALL swap_dimensions(ind) 109 CALL swap_geometry(ind) 110 ps=f_ps(ind) 111 p=f_p(ind) 112 pks=f_pks(ind) 113 pk=f_pk(ind) 114 theta_rhodz=f_theta_rhodz(ind) 115 temp=f_temp(ind) 116 117 !$OMP BARRIER 118 CALL compute_pression(ps,p,0) 119 !$OMP BARRIER 120 CALL compute_exner(ps,p,pks,pk,0) 121 !$OMP BARRIER 122 CALL compute_temperature2theta_rhodz(p, pk, temp, theta_rhodz, 0) 123 ENDDO 124 !$OMP BARRIER 125 126 END SUBROUTINE temperature2theta_rhodz 127 128 52 129 53 130 SUBROUTINE theta2theta_rhodz(f_ps,f_theta,f_theta_rhodz) … … 63 140 INTEGER :: ind 64 141 142 !$OMP BARRIER 65 143 DO ind=1,ndomain 66 144 IF (.NOT. assigned_domain(ind)) CYCLE … … 72 150 CALL compute_theta2theta_rhodz(ps, theta, theta_rhodz,0) 73 151 ENDDO 152 !$OMP BARRIER 74 153 75 154 END SUBROUTINE theta2theta_rhodz … … 77 156 SUBROUTINE compute_theta2theta_rhodz(ps,theta, theta_rhodz,offset) 78 157 USE icosa 79 USE pression_mod 158 USE disvert_mod 159 USE omp_para 80 160 IMPLICIT NONE 81 161 REAL(rstd),INTENT(IN) :: ps(iim*jjm) … … 84 164 INTEGER,INTENT(IN) :: offset 85 165 INTEGER :: i,j,ij,l 86 REAL(rstd),ALLOCATABLE,SAVE :: p(:,:) 87 !$OMP THREADPRIVATE(p) 88 89 ALLOCATE( p(iim*jjm,llm+1)) 90 CALL compute_pression(ps,p,offset) 91 92 DO l = 1, llm 93 DO j=jj_begin-offset,jj_end+offset 94 DO i=ii_begin-offset,ii_end+offset 95 ij=(j-1)*iim+i 96 theta_rhodz(ij,l) = theta(ij,l) * (p(ij,l)-p(ij,l+1))/g 97 ENDDO 98 ENDDO 99 ENDDO 100 101 DEALLOCATE( p) 166 167 !$OMP BARRIER 168 DO l = ll_begin, ll_end 169 DO j=jj_begin-offset,jj_end+offset 170 DO i=ii_begin-offset,ii_end+offset 171 ij=(j-1)*iim+i 172 theta_rhodz(ij,l) = theta(ij,l) * ( (ap(l)-ap(l+1)) + ( bp(l)- bp(l+1))* ps(ij) )/g 173 ENDDO 174 ENDDO 175 ENDDO 176 !$OMP BARRIER 177 102 178 103 179 END SUBROUTINE compute_theta2theta_rhodz … … 105 181 SUBROUTINE compute_theta_rhodz2theta(ps,theta_rhodz,theta,offset) 106 182 USE icosa 107 USE pression_mod 183 USE disvert_mod 184 USE omp_para 108 185 IMPLICIT NONE 109 186 REAL(rstd),INTENT(IN) :: ps(iim*jjm) … … 112 189 INTEGER,INTENT(IN) :: offset 113 190 INTEGER :: i,j,ij,l 114 REAL(rstd),SAVE,ALLOCATABLE :: p(:,:) 115 !$OMP THREADPRIVATE(p) 116 117 ALLOCATE( p(iim*jjm,llm+1)) 118 119 CALL compute_pression(ps,p,offset) 120 121 DO l = 1, llm 122 DO j=jj_begin-offset,jj_end+offset 123 DO i=ii_begin-offset,ii_end+offset 124 ij=(j-1)*iim+i 125 theta(ij,l) = theta_rhodz(ij,l) / ((p(ij,l)-p(ij,l+1))/g) 126 ENDDO 127 ENDDO 128 ENDDO 129 130 DEALLOCATE( p) 191 192 !$OMP BARRIER 193 DO l = ll_begin, ll_end 194 DO j=jj_begin-offset,jj_end+offset 195 DO i=ii_begin-offset,ii_end+offset 196 ij=(j-1)*iim+i 197 theta(ij,l) = theta_rhodz(ij,l) / ( (ap(l)-ap(l+1)) + ( bp(l)- bp(l+1))* ps(ij) )/g 198 ENDDO 199 ENDDO 200 ENDDO 201 !$OMP BARRIER 202 131 203 132 204 END SUBROUTINE compute_theta_rhodz2theta 133 205 134 SUBROUTINE compute_theta_rhodz2temperature(ps,theta_rhodz,temp,offset) 135 USE icosa 136 USE pression_mod 137 USE exner_mod 138 IMPLICIT NONE 139 REAL(rstd),INTENT(IN) :: ps(iim*jjm) 206 207 208 209 210 211 SUBROUTINE compute_theta_rhodz2temperature(p,pk,theta_rhodz,temp,offset) 212 USE icosa 213 USE pression_mod 214 USE exner_mod 215 USE omp_para 216 IMPLICIT NONE 217 REAL(rstd),INTENT(IN) :: p(iim*jjm,llm+1) 218 REAL(rstd),INTENT(IN) :: pk(iim*jjm,llm) 140 219 REAL(rstd),INTENT(IN) :: theta_rhodz(iim*jjm,llm) 141 220 REAL(rstd),INTENT(OUT) :: temp(iim*jjm,llm) 142 221 INTEGER,INTENT(IN) :: offset 143 222 INTEGER :: i,j,ij,l 144 REAL(rstd) :: p(iim*jjm,llm+1)145 REAL(rstd) :: pk(iim*jjm,llm)146 REAL(rstd) :: pks(iim*jjm)147 148 CALL compute_pression(ps,p,offset)149 CALL compute_exner(ps,p,pks,pk,offset)150 223 151 DO l = 1, llm 224 ! flush p 225 !$OMP BARRIER 226 DO l = ll_begin, ll_end 152 227 DO j=jj_begin-offset,jj_end+offset 153 228 DO i=ii_begin-offset,ii_end+offset … … 157 232 ENDDO 158 233 ENDDO 234 !$OMP BARRIER 235 159 236 160 237 END SUBROUTINE compute_theta_rhodz2temperature 161 238 162 SUBROUTINE compute_temperature2theta_rhodz(ps,temp,theta_rhodz,offset) 163 USE icosa 164 USE pression_mod 165 USE exner_mod 166 IMPLICIT NONE 167 REAL(rstd),INTENT(IN) :: ps(iim*jjm) 239 SUBROUTINE compute_temperature2theta_rhodz(p,pk,temp,theta_rhodz,offset) 240 USE icosa 241 USE pression_mod 242 USE exner_mod 243 USE omp_para 244 IMPLICIT NONE 245 REAL(rstd),INTENT(IN) :: p(iim*jjm,llm+1) 246 REAL(rstd),INTENT(IN) :: pk(iim*jjm,llm) 168 247 REAL(rstd),INTENT(OUT) :: theta_rhodz(iim*jjm,llm) 169 REAL(rstd),INTENT(IN) :: temp(iim*jjm,llm) 170 INTEGER,INTENT(IN) :: offset 171 INTEGER :: i,j,ij,l 172 REAL(rstd) :: p(iim*jjm,llm+1) 173 REAL(rstd) :: pk(iim*jjm,llm) 174 REAL(rstd) :: pks(iim*jjm) 175 176 CALL compute_pression(ps,p,offset) 177 CALL compute_exner(ps,p,pks,pk,offset) 248 REAL(rstd),INTENT(IN) :: temp(iim*jjm,llm) 249 INTEGER,INTENT(IN) :: offset 250 INTEGER :: i,j,ij,l 251 178 252 179 DO l = 1, llm 253 ! flush p 254 !$OMP BARRIER 255 256 DO l = ll_begin, ll_end 180 257 DO j=jj_begin-offset,jj_end+offset 181 258 DO i=ii_begin-offset,ii_end+offset … … 185 262 ENDDO 186 263 ENDDO 264 !$OMP BARRIER 187 265 188 266 END SUBROUTINE compute_temperature2theta_rhodz -
codes/icosagcm/trunk/src/time.f90
r278 r295 19 19 INTEGER,SAVE :: itau_out, itau_adv, itau_dissip, itau_physics, itaumax 20 20 !$OMP THREADPRIVATE(itau_out, itau_adv, itau_dissip, itau_physics, itaumax) 21 22 INTEGER,SAVE :: itau_check_conserv 23 !$OMP THREADPRIVATE(itau_check_conserv) 21 24 22 25 INTEGER,SAVE :: day_step,ndays … … 38 41 39 42 PUBLIC create_time_counter_header, update_time_counter, close_time_counter, init_time, & 40 dt, write_period, itau_out, itau_adv, itau_dissip, itau_physics, itaumax, & 41 day_step,ndays,jD_ref,jH_ref,day_ini,day_end,annee_ref,day_ref,an, mois, jour,heure, & 42 calend,time_style,itau0 43 dt, write_period, itau_out, itau_adv, itau_dissip, itau_physics, itaumax, & 44 itau_check_conserv, & 45 day_step,ndays,jD_ref,jH_ref,day_ini,day_end,annee_ref,day_ref, & 46 an, mois, jour,heure, calend,time_style,itau0 43 47 44 48 … … 82 86 itau_adv=1 83 87 CALL getin('itau_adv',itau_adv) 84 88 85 89 itau_dissip=1 86 90 CALL getin('itau_dissip',itau_dissip) 87 91 88 92 itau_physics=1 89 93 CALL getin('itau_physics',itau_physics) 90 94 95 itau_check_conserv=HUGE(itau_check_conserv) 96 CALL getin('itau_check_conserv',itau_check_conserv) 97 91 98 IF (is_mpi_root) THEN 92 99 PRINT *, 'itaumax=',itaumax -
codes/icosagcm/trunk/src/timeloop_gcm.f90
r281 r295 39 39 USE output_field_mod 40 40 USE write_field 41 USE theta2theta_rhodz_mod 41 42 IMPLICIT NONE 42 43 … … 117 118 END SELECT 118 119 119 120 CALL init_theta2theta_rhodz 120 121 CALL init_dissip 121 122 CALL init_caldyn … … 124 125 CALL init_check_conserve 125 126 CALL init_physics 127 126 128 127 129 CALL etat0(f_ps,f_mass,f_phis,f_theta_rhodz,f_u, f_q) … … 157 159 USE output_field_mod 158 160 USE write_etat0_mod 161 USE checksum_mod 159 162 IMPLICIT NONE 160 163 REAL(rstd),POINTER :: q(:,:,:) … … 172 175 INTEGER :: stop_clock 173 176 INTEGER :: rate_clock 177 INTEGER :: l 174 178 175 179 … … 178 182 ! CALL write_restart(f_ps,f_mass,f_phis,f_theta_rhodz,f_u,f_q) 179 183 184 CALL switch_omp_distrib_level 180 185 CALL caldyn_BC(f_phis, f_wflux) ! set constant values in first/last interfaces 181 182 ! !$OMP BARRIER186 187 !$OMP BARRIER 183 188 DO ind=1,ndomain 184 189 IF (.NOT. assigned_domain(ind)) CYCLE … … 189 194 CALL compute_rhodz(.TRUE., ps, rhodz) ! save rhodz for transport scheme before dynamics update ps 190 195 ELSE 191 rhodz(:,:)=mass(:,:) 196 DO l=ll_begin,ll_end 197 rhodz(:,l)=mass(:,l) 198 ENDDO 192 199 END IF 193 200 END DO 201 !$OMP BARRIER 194 202 fluxt_zero=.TRUE. 195 203 … … 224 232 ENDIF 225 233 226 !$OMP MASTER 227 IF (is_mpi_root) PRINT *,"It No :",It," t :",dt*It 228 !$OMP END MASTER 234 IF (is_master) PRINT *,"It No :",It," t :",dt*It 235 229 236 IF (mod(it,itau_out)==0 ) THEN 230 237 CALL update_time_counter(dt*it) 231 238 CALL output_field("q",f_q) 232 CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,it)233 239 ENDIF 234 240 … … 256 262 257 263 IF(caldyn_eta==eta_mass) THEN 264 !ym flush ps 265 !$OMP BARRIER 258 266 DO ind=1,ndomain 259 267 IF (.NOT. assigned_domain(ind)) CYCLE … … 267 275 ! CALL wait_message(req_mass) 268 276 CALL dissip(f_u,f_du,f_mass,f_phis, f_theta_rhodz,f_dtheta_rhodz) 277 269 278 ! CALL send_message(f_mass,req_mass) 270 279 ! CALL wait_message(req_mass) … … 291 300 292 301 CALL physics(it,f_phis, f_ps, f_theta_rhodz, f_u, f_q) 302 303 IF (MOD(it,itau_check_conserv)==0) THEN 304 CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,it) 305 ENDIF 293 306 294 307 ENDDO … … 324 337 IF(caldyn_eta==eta_mass) THEN ! update ps 325 338 ps=f_ps(ind) ; dps=f_dps(ind) ; 326 IF ( omp_first) THEN339 IF (is_omp_first_level) THEN 327 340 !$SIMD 328 341 DO ij=ij_begin,ij_end … … 376 389 ! if mass coordinate, deal with ps first on one core 377 390 IF(caldyn_eta==eta_mass) THEN 378 IF ( omp_first) THEN391 IF (is_omp_first_level) THEN 379 392 380 393 DO ind=1,ndomain -
codes/icosagcm/trunk/src/transfert_mpi.f90
r266 r295 1119 1119 1120 1120 DO ind=1,ndomain 1121 IF (.NOT. assigned_domain(ind) ) CYCLE1121 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1122 1122 1123 1123 rval2d=>field(ind)%rval2d … … 1152 1152 1153 1153 DO ind=1,ndomain 1154 IF (.NOT. assigned_domain(ind) ) CYCLE1154 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1155 1155 rval2d=>field(ind)%rval2d 1156 1156 req=>message%request(ind) … … 1192 1192 1193 1193 DO ind=1,ndomain 1194 IF (.NOT. assigned_domain(ind) ) CYCLE1194 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1195 1195 1196 1196 dim3=size(field(ind)%rval3d,2) … … 1226 1226 1227 1227 DO ind=1,ndomain 1228 IF (.NOT. assigned_domain(ind) ) CYCLE1228 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1229 1229 dim3=size(field(ind)%rval3d,2) 1230 1230 rval3d=>field(ind)%rval3d … … 1263 1263 1264 1264 DO ind=1,ndomain 1265 IF (.NOT. assigned_domain(ind) ) CYCLE1265 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master ) CYCLE 1266 1266 1267 1267 dim3=size(field(ind)%rval4d,2) … … 1302 1302 1303 1303 DO ind=1,ndomain 1304 IF (.NOT. assigned_domain(ind) ) CYCLE1304 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1305 1305 1306 1306 dim3=size(field(ind)%rval4d,2) … … 1421 1421 1422 1422 DO ind=1,ndomain 1423 IF (.NOT. assigned_domain(ind) ) CYCLE1423 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1424 1424 1425 1425 rval2d=>field(ind)%rval2d … … 1452 1452 1453 1453 DO ind=1,ndomain 1454 IF (.NOT. assigned_domain(ind) ) CYCLE1454 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1455 1455 1456 1456 rval3d=>field(ind)%rval3d … … 1485 1485 1486 1486 DO ind=1,ndomain 1487 IF (.NOT. assigned_domain(ind) ) CYCLE1487 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1488 1488 1489 1489 rval4d=>field(ind)%rval4d -
codes/icosagcm/trunk/src/transfert_omp.f90
r238 r295 34 34 END INTERFACE 35 35 36 PUBLIC bcast_omp, reduce_sum_omp, allreduce_sum_omp 36 37 INTERFACE reduce_max_omp 38 MODULE PROCEDURE reduce_max_omp_i,reduce_max_omp_i1,reduce_max_omp_i2,reduce_max_omp_i3,reduce_max_omp_i4, & 39 reduce_max_omp_r,reduce_max_omp_r1,reduce_max_omp_r2,reduce_max_omp_r3,reduce_max_omp_r4 40 END INTERFACE 41 42 INTERFACE allreduce_max_omp 43 MODULE PROCEDURE allreduce_max_omp_i,allreduce_max_omp_i1,allreduce_max_omp_i2,allreduce_max_omp_i3,allreduce_max_omp_i4, & 44 allreduce_max_omp_r,allreduce_max_omp_r1,allreduce_max_omp_r2,allreduce_max_omp_r3,allreduce_max_omp_r4 45 END INTERFACE 46 47 48 PUBLIC bcast_omp, reduce_sum_omp, allreduce_sum_omp, reduce_max_omp, allreduce_max_omp 37 49 38 50 CONTAINS … … 521 533 END SUBROUTINE allreduce_sum_omp_r4 522 534 535 536 537 538 539 540 541 542 543 544 545 546 SUBROUTINE reduce_max_omp_i(VarIn, VarOut) 547 IMPLICIT NONE 548 549 INTEGER,INTENT(IN) :: VarIn 550 INTEGER,INTENT(OUT) :: VarOut 551 INTEGER :: VarIn_tmp(1) 552 INTEGER :: VarOut_tmp(1) 553 554 VarIn_tmp(1)=VarIn 555 CALL Check_buffer_i(1) 556 CALL reduce_max_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i) 557 VarOut=VarOut_tmp(1) 558 559 END SUBROUTINE reduce_max_omp_i 560 561 SUBROUTINE reduce_max_omp_i1(VarIn, VarOut) 562 IMPLICIT NONE 563 564 INTEGER,INTENT(IN),DIMENSION(:) :: VarIn 565 INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut 566 567 CALL Check_buffer_i(size(VarIn)) 568 CALL reduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 569 570 END SUBROUTINE reduce_max_omp_i1 571 572 573 SUBROUTINE reduce_max_omp_i2(VarIn, VarOut) 574 IMPLICIT NONE 575 576 INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn 577 INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut 578 579 CALL Check_buffer_i(size(VarIn)) 580 CALL reduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 581 582 END SUBROUTINE reduce_max_omp_i2 583 584 585 SUBROUTINE reduce_max_omp_i3(VarIn, VarOut) 586 IMPLICIT NONE 587 588 INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn 589 INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 590 591 CALL Check_buffer_i(size(VarIn)) 592 CALL reduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 593 594 END SUBROUTINE reduce_max_omp_i3 595 596 597 SUBROUTINE reduce_max_omp_i4(VarIn, VarOut) 598 IMPLICIT NONE 599 600 INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 601 INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 602 603 CALL Check_buffer_i(size(VarIn)) 604 CALL reduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 605 606 END SUBROUTINE reduce_max_omp_i4 607 608 609 SUBROUTINE reduce_max_omp_r(VarIn, VarOut) 610 IMPLICIT NONE 611 612 REAL,INTENT(IN) :: VarIn 613 REAL,INTENT(OUT) :: VarOut 614 REAL :: VarIn_tmp(1) 615 REAL :: VarOut_tmp(1) 616 617 VarIn_tmp(1)=VarIn 618 CALL Check_buffer_r(1) 619 CALL reduce_max_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r) 620 VarOut=VarOut_tmp(1) 621 622 END SUBROUTINE reduce_max_omp_r 623 624 SUBROUTINE reduce_max_omp_r1(VarIn, VarOut) 625 IMPLICIT NONE 626 627 REAL,INTENT(IN),DIMENSION(:) :: VarIn 628 REAL,INTENT(OUT),DIMENSION(:) :: VarOut 629 630 CALL Check_buffer_r(size(VarIn)) 631 CALL reduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 632 633 END SUBROUTINE reduce_max_omp_r1 634 635 636 SUBROUTINE reduce_max_omp_r2(VarIn, VarOut) 637 IMPLICIT NONE 638 639 REAL,INTENT(IN),DIMENSION(:,:) :: VarIn 640 REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut 641 642 CALL Check_buffer_r(size(VarIn)) 643 CALL reduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 644 645 END SUBROUTINE reduce_max_omp_r2 646 647 648 SUBROUTINE reduce_max_omp_r3(VarIn, VarOut) 649 IMPLICIT NONE 650 651 REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn 652 REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 653 654 CALL Check_buffer_r(size(VarIn)) 655 CALL reduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 656 657 END SUBROUTINE reduce_max_omp_r3 658 659 660 SUBROUTINE reduce_max_omp_r4(VarIn, VarOut) 661 IMPLICIT NONE 662 663 REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 664 REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 665 666 CALL Check_buffer_r(size(VarIn)) 667 CALL reduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 668 669 END SUBROUTINE reduce_max_omp_r4 670 671 672 673 674 SUBROUTINE allreduce_max_omp_i(VarIn, VarOut) 675 IMPLICIT NONE 676 677 INTEGER,INTENT(IN) :: VarIn 678 INTEGER,INTENT(OUT) :: VarOut 679 INTEGER :: VarIn_tmp(1) 680 INTEGER :: VarOut_tmp(1) 681 682 VarIn_tmp(1)=VarIn 683 CALL Check_buffer_i(1) 684 CALL allreduce_max_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i) 685 VarOut=VarOut_tmp(1) 686 687 END SUBROUTINE allreduce_max_omp_i 688 689 SUBROUTINE allreduce_max_omp_i1(VarIn, VarOut) 690 IMPLICIT NONE 691 692 INTEGER,INTENT(IN),DIMENSION(:) :: VarIn 693 INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut 694 695 CALL Check_buffer_i(size(VarIn)) 696 CALL allreduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 697 698 END SUBROUTINE allreduce_max_omp_i1 699 700 701 SUBROUTINE allreduce_max_omp_i2(VarIn, VarOut) 702 IMPLICIT NONE 703 704 INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn 705 INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut 706 707 CALL Check_buffer_i(size(VarIn)) 708 CALL allreduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 709 710 END SUBROUTINE allreduce_max_omp_i2 711 712 713 SUBROUTINE allreduce_max_omp_i3(VarIn, VarOut) 714 IMPLICIT NONE 715 716 INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn 717 INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 718 719 CALL Check_buffer_i(size(VarIn)) 720 CALL allreduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 721 722 END SUBROUTINE allreduce_max_omp_i3 723 724 725 SUBROUTINE allreduce_max_omp_i4(VarIn, VarOut) 726 IMPLICIT NONE 727 728 INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 729 INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 730 731 CALL Check_buffer_i(size(VarIn)) 732 CALL allreduce_max_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 733 734 END SUBROUTINE allreduce_max_omp_i4 735 736 737 SUBROUTINE allreduce_max_omp_r(VarIn, VarOut) 738 IMPLICIT NONE 739 740 REAL,INTENT(IN) :: VarIn 741 REAL,INTENT(OUT) :: VarOut 742 REAL :: VarIn_tmp(1) 743 REAL :: VarOut_tmp(1) 744 745 VarIn_tmp(1)=VarIn 746 CALL Check_buffer_r(1) 747 CALL allreduce_max_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r) 748 VarOut=VarOut_tmp(1) 749 750 END SUBROUTINE allreduce_max_omp_r 751 752 SUBROUTINE allreduce_max_omp_r1(VarIn, VarOut) 753 IMPLICIT NONE 754 755 REAL,INTENT(IN),DIMENSION(:) :: VarIn 756 REAL,INTENT(OUT),DIMENSION(:) :: VarOut 757 758 CALL Check_buffer_r(size(VarIn)) 759 CALL allreduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 760 761 END SUBROUTINE allreduce_max_omp_r1 762 763 764 SUBROUTINE allreduce_max_omp_r2(VarIn, VarOut) 765 IMPLICIT NONE 766 767 REAL,INTENT(IN),DIMENSION(:,:) :: VarIn 768 REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut 769 770 CALL Check_buffer_r(size(VarIn)) 771 CALL allreduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 772 773 END SUBROUTINE allreduce_max_omp_r2 774 775 776 SUBROUTINE allreduce_max_omp_r3(VarIn, VarOut) 777 IMPLICIT NONE 778 779 REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn 780 REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 781 782 CALL Check_buffer_r(size(VarIn)) 783 CALL allreduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 784 785 END SUBROUTINE allreduce_max_omp_r3 786 787 788 SUBROUTINE allreduce_max_omp_r4(VarIn, VarOut) 789 IMPLICIT NONE 790 791 REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 792 REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 793 794 CALL Check_buffer_r(size(VarIn)) 795 CALL allreduce_max_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 796 797 END SUBROUTINE allreduce_max_omp_r4 798 523 799 524 800 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 740 1016 741 1017 END SUBROUTINE allreduce_sum_omp_rgen 1018 1019 1020 1021 1022 1023 1024 SUBROUTINE reduce_max_omp_igen(VarIn,VarOut,dimsize,Buff) 1025 IMPLICIT NONE 1026 1027 INTEGER,INTENT(IN) :: dimsize 1028 INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn 1029 INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1030 INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1031 1032 INTEGER :: i 1033 1034 !$OMP MASTER 1035 Buff(:)=VarIn(1) 1036 !$OMP END MASTER 1037 !$OMP BARRIER 1038 1039 !$OMP CRITICAL 1040 DO i=1,dimsize 1041 Buff(i)=MAX(Buff(i),VarIn(i)) 1042 ENDDO 1043 !$OMP END CRITICAL 1044 !$OMP BARRIER 1045 1046 !$OMP MASTER 1047 DO i=1,dimsize 1048 VarOut(i)=Buff(i) 1049 ENDDO 1050 !$OMP END MASTER 1051 !$OMP BARRIER 1052 1053 END SUBROUTINE reduce_max_omp_igen 1054 1055 SUBROUTINE reduce_max_omp_rgen(VarIn,VarOut,dimsize,Buff) 1056 IMPLICIT NONE 1057 1058 INTEGER,INTENT(IN) :: dimsize 1059 REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn 1060 REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1061 REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1062 1063 INTEGER :: i 1064 1065 !$OMP MASTER 1066 Buff(:)=VarIn(1) 1067 !$OMP END MASTER 1068 !$OMP BARRIER 1069 1070 !$OMP CRITICAL 1071 DO i=1,dimsize 1072 Buff(i)=MAX(Buff(i),VarIn(i)) 1073 ENDDO 1074 !$OMP END CRITICAL 1075 !$OMP BARRIER 1076 1077 DO i=1,dimsize 1078 VarOut(i)=Buff(i) 1079 ENDDO 1080 !$OMP BARRIER 1081 1082 END SUBROUTINE reduce_max_omp_rgen 1083 1084 1085 1086 SUBROUTINE allreduce_max_omp_igen(VarIn,VarOut,dimsize,Buff) 1087 IMPLICIT NONE 1088 1089 INTEGER,INTENT(IN) :: dimsize 1090 INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn 1091 INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1092 INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1093 1094 INTEGER :: i 1095 1096 !$OMP MASTER 1097 Buff(:)=VarIn(1) 1098 !$OMP END MASTER 1099 !$OMP BARRIER 1100 1101 !$OMP CRITICAL 1102 DO i=1,dimsize 1103 Buff(i)=MAX(Buff(i),VarIn(i)) 1104 ENDDO 1105 !$OMP END CRITICAL 1106 !$OMP BARRIER 1107 1108 DO i=1,dimsize 1109 VarOut(i)=Buff(i) 1110 ENDDO 1111 !$OMP BARRIER 1112 1113 END SUBROUTINE allreduce_max_omp_igen 1114 1115 SUBROUTINE allreduce_max_omp_rgen(VarIn,VarOut,dimsize,Buff) 1116 IMPLICIT NONE 1117 1118 INTEGER,INTENT(IN) :: dimsize 1119 REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn 1120 REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1121 REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1122 1123 INTEGER :: i 1124 1125 !$OMP MASTER 1126 Buff(:)=VarIn(1) 1127 !$OMP END MASTER 1128 !$OMP BARRIER 1129 1130 !$OMP CRITICAL 1131 DO i=1,dimsize 1132 Buff(i)=MAX(Buff(i),VarIn(i)) 1133 ENDDO 1134 !$OMP END CRITICAL 1135 !$OMP BARRIER 1136 1137 DO i=1,dimsize 1138 VarOut(i)=Buff(i) 1139 ENDDO 1140 1141 !$OMP BARRIER 1142 1143 END SUBROUTINE allreduce_max_omp_rgen 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 742 1155 743 1156 END MODULE transfert_omp_mod -
codes/icosagcm/trunk/src/vertical_interp.f90
r186 r295 21 21 USE icosa 22 22 USE pression_mod 23 USE omp_para 23 24 IMPLICIT NONE 24 25 TYPE(t_field),POINTER :: f_ps(:) … … 48 49 49 50 SUBROUTINE compute_vertical_interp(p,in,out,pval) 51 USE omp_para 50 52 IMPLICIT NONE 51 53 REAL(rstd),INTENT(IN) :: p(iim*jjm,llm+1) … … 56 58 INTEGER :: i,j,ij,l 57 59 58 DO j=jj_begin-1,jj_end+1 59 DO i=ii_begin-1,ii_end+1 60 ij=(j-1)*iim+i 61 l=llm-1 62 DO WHILE(0.5*(p(ij,l)+p(ij,l+1))<pval .AND. l>1) 63 l=l-1 60 !$OMP BARRIER 61 IF (is_omp_level_master) THEN 62 63 DO j=jj_begin-1,jj_end+1 64 DO i=ii_begin-1,ii_end+1 65 ij=(j-1)*iim+i 66 l=llm-1 67 DO WHILE(0.5*(p(ij,l)+p(ij,l+1))<pval .AND. l>1) 68 l=l-1 69 ENDDO 70 pmid=0.5*(p(ij,l)+p(ij,l+1)) 71 pmidp1=0.5*(p(ij,l+1)+p(ij,l+2)) 72 73 coeff=(pval-pmid)/(pmid-pmidp1) 74 75 out(ij)=in(ij,l)+coeff*(in(ij,l)-in(ij,l+1)) 64 76 ENDDO 65 pmid=0.5*(p(ij,l)+p(ij,l+1))66 pmidp1=0.5*(p(ij,l+1)+p(ij,l+2))67 68 coeff=(pval-pmid)/(pmid-pmidp1)69 70 out(ij)=in(ij,l)+coeff*(in(ij,l)-in(ij,l+1))71 77 ENDDO 72 ENDDO 78 79 ENDIF 80 !$OMP BARRIER 73 81 74 82 END SUBROUTINE compute_vertical_interp -
codes/icosagcm/trunk/src/vorticity.f90
r186 r295 29 29 USE icosa 30 30 USE disvert_mod 31 USE omp_para 31 32 IMPLICIT NONE 32 33 REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm) … … 34 35 INTEGER :: i,j,ij,l 35 36 36 DO l = 1,llm37 DO l = ll_begin,ll_end 37 38 DO j=jj_begin-1,jj_end+1 38 39 DO i=ii_begin-1,ii_end+1 -
codes/icosagcm/trunk/src/wind.f90
r266 r295 47 47 SUBROUTINE compute_wind_centered(ue,ucenter) 48 48 USE icosa 49 49 USE omp_para 50 50 IMPLICIT NONE 51 51 REAL(rstd) :: ue(3*iim*jjm,llm) … … 53 53 INTEGER :: i,j,ij,l 54 54 55 DO l= 1,llm55 DO l=ll_begin,ll_end 56 56 DO j=jj_begin,jj_end 57 57 DO i=ii_begin,ii_end … … 73 73 SUBROUTINE compute_wind_on_edge(ue,uedge) 74 74 USE icosa 75 USE omp_para 75 76 76 77 IMPLICIT NONE … … 83 84 CALL compute_tangential_compound(ue,ut) 84 85 85 DO l= 1,llm86 DO l=ll_begin,ll_end 86 87 DO j=jj_begin,jj_end 87 88 DO i=ii_begin,ii_end … … 100 101 SUBROUTINE compute_tangential_compound(ue,ut) 101 102 USE icosa 103 USE omp_para 102 104 IMPLICIT NONE 103 105 REAL(rstd) :: ue(3*iim*jjm,llm) … … 105 107 INTEGER :: i,j,l,ij 106 108 107 DO l= 1,llm109 DO l=ll_begin,ll_end 108 110 DO j=jj_begin,jj_end 109 111 DO i=ii_begin,ii_end … … 155 157 SUBROUTINE compute_wind_lonlat_compound(u, ulon, ulat) 156 158 USE icosa 159 USE omp_para 157 160 158 161 IMPLICIT NONE … … 164 167 165 168 166 DO l= 1,llm169 DO l=ll_begin,ll_end 167 170 DO j=jj_begin-1,jj_end+1 168 171 DO i=ii_begin-1,ii_end+1 … … 184 187 SUBROUTINE compute_wind_from_lonlat_compound(ulon, ulat, u) 185 188 USE icosa 189 USE omp_para 186 190 187 191 IMPLICIT NONE … … 192 196 INTEGER :: i,j,ij,l 193 197 194 DO l= 1,llm198 DO l=ll_begin,ll_end 195 199 DO j=jj_begin-1,jj_end+1 196 200 DO i=ii_begin-1,ii_end+1 … … 207 211 SUBROUTINE compute_wind_centered_from_lonlat_compound(ulon, ulat, u) 208 212 USE icosa 213 USE omp_para 209 214 210 215 IMPLICIT NONE … … 214 219 215 220 INTEGER :: i,j,ij,l 216 DO l= 1,llm221 DO l=ll_begin,ll_end 217 222 DO j=jj_begin-1,jj_end+1 218 223 DO i=ii_begin-1,ii_end+1 … … 248 253 SUBROUTINE compute_wind_perp_from_lonlat_compound(ulon, ulat, up) 249 254 USE icosa 255 USE omp_para 250 256 251 257 IMPLICIT NONE … … 259 265 CALL compute_wind_from_lonlat_compound(ulon, ulat, u) 260 266 261 DO l= 1,llm267 DO l=ll_begin,ll_end 262 268 DO j=jj_begin-1,jj_end+1 263 269 DO i=ii_begin-1,ii_end+1 … … 297 303 SUBROUTINE compute_wind_centered_lonlat_compound(uc, ulon, ulat) 298 304 USE icosa 305 USE omp_para 299 306 300 307 IMPLICIT NONE … … 306 313 307 314 308 DO l= 1,llm315 DO l=ll_begin,ll_end 309 316 DO j=jj_begin,jj_end 310 317 DO i=ii_begin,ii_end … … 320 327 SUBROUTINE compute_wind_centered_from_wind_lonlat_centered(ulon, ulat,uc) 321 328 USE icosa 329 USE omp_para 322 330 323 331 IMPLICIT NONE … … 329 337 330 338 331 DO l= 1,llm339 DO l=ll_begin,ll_end 332 340 DO j=jj_begin,jj_end 333 341 DO i=ii_begin,ii_end … … 344 352 SUBROUTINE compute_wind_perp_from_wind_centered(uc,un) 345 353 USE icosa 354 USE omp_para 346 355 347 356 IMPLICIT NONE … … 352 361 353 362 354 DO l= 1,llm363 DO l=ll_begin,ll_end 355 364 DO j=jj_begin,jj_end 356 365 DO i=ii_begin,ii_end
Note: See TracChangeset
for help on using the changeset viewer.