Index: LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90 (revision 5267) +++ (revision ) @@ -1,53 +1,0 @@ -! -! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $ -! -! -! -SUBROUTINE abort_gcm(modname, message, ierr) - - USE IOIPSL - - USE parallel_lmdz - INCLUDE "iniprint.h" - - ! - ! Stops the simulation cleanly, closing files and printing various - ! comments - ! - ! Input: modname = name of calling program - ! message = stuff to print - ! ierr = severity of situation ( = 0 normal ) - - character(len=*), intent(in):: modname - integer :: ierr, ierror_mpi - character(len=*), intent(in):: message - - write(lunout,*) 'in abort_gcm' -!$OMP MASTER - call histclo - call restclo - if (MPI_rank .eq. 0) then - call getin_dump - endif -!$OMP END MASTER - ! call histclo(2) - ! call histclo(3) - ! call histclo(4) - ! call histclo(5) - write(lunout,*) 'Stopping in ', modname - write(lunout,*) 'Reason = ',message - if (ierr .eq. 0) then - write(lunout,*) 'Everything is cool' - else - write(lunout,*) 'Houston, we have a problem, ierr = ', ierr - - if (using_mpi) THEN -!$OMP CRITICAL (MPI_ABORT_GCM) - call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi) -!$OMP END CRITICAL (MPI_ABORT_GCM) - else - stop 1 - endif - - endif -END SUBROUTINE abort_gcm Index: LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90 (revision 5268) @@ -0,0 +1,53 @@ +! +! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $ +! +! +! +SUBROUTINE abort_gcm(modname, message, ierr) + + USE IOIPSL + + USE parallel_lmdz + INCLUDE "iniprint.h" + + ! + ! Stops the simulation cleanly, closing files and printing various + ! comments + ! + ! Input: modname = name of calling program + ! message = stuff to print + ! ierr = severity of situation ( = 0 normal ) + + character(len=*), intent(in):: modname + integer :: ierr, ierror_mpi + character(len=*), intent(in):: message + + write(lunout,*) 'in abort_gcm' +!$OMP MASTER + call histclo + call restclo + if (MPI_rank .eq. 0) then + call getin_dump + endif +!$OMP END MASTER + ! call histclo(2) + ! call histclo(3) + ! call histclo(4) + ! call histclo(5) + write(lunout,*) 'Stopping in ', modname + write(lunout,*) 'Reason = ',message + if (ierr .eq. 0) then + write(lunout,*) 'Everything is cool' + else + write(lunout,*) 'Houston, we have a problem, ierr = ', ierr + + if (using_mpi) THEN +!$OMP CRITICAL (MPI_ABORT_GCM) + call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi) +!$OMP END CRITICAL (MPI_ABORT_GCM) + else + stop 1 + endif + + endif +END SUBROUTINE abort_gcm Index: LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90 (revision 5267) +++ (revision ) @@ -1,294 +1,0 @@ -! -! $Header$ -! -SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, & - du,dv,dteta) - USE parallel_lmdz - USE write_field_loc - USE advect_new_mod - USE comconst_mod, ONLY: daysec - USE logic_mod, ONLY: conser - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - IMPLICIT NONE - !======================================================================= - ! - ! Auteurs: P. Le Van , Fr. Hourdin . - ! ------- - ! - ! Objet: - ! ------ - ! - ! ************************************************************* - ! .... calcul des termes d'advection vertic.pour u,v,teta,q ... - ! ************************************************************* - ! ces termes sont ajoutes a du,dv,dteta et dq . - ! Modif F.Forget 03/94 : on retire q de advect - ! - !======================================================================= - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - include "dimensions.h" - include "paramet.h" - include "comgeom.h" - - ! Arguments: - ! ---------- - - REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) - REAL :: teta(ijb_u:ije_u,llm) - REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm) - REAL :: w(ijb_u:ije_u,llm) - REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm) - REAL :: dteta(ijb_u:ije_u,llm) - ! Local: - ! ------ - - REAL :: wsur2(ijb_u:ije_u) - REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u) - REAL :: deuxjour, ww, gt, uu, vv - - INTEGER :: ij,l,ijb,ije - EXTERNAL SSUM - REAL :: SSUM - - - - !----------------------------------------------------------------------- - ! 2. Calculs preliminaires: - ! ------------------------- - - IF (conser.AND.1==0) THEN - deuxjour = 2. * daysec - - DO ij = 1, ip1jmp1 - unsaire2(ij) = unsaire(ij) * unsaire(ij) - END DO - END IF - - - !------------------ -yy ---------------------------------------------- - ! . Calcul de u - -!$OMP MASTER - ijb=ij_begin - ije=ij_end - if (pole_nord) ijb=ijb+iip1 - if (pole_sud) ije=ije-iip1 - - DO ij=ijb,ije - du2(ij,1)=0. - du1(ij,llm)=0. - ENDDO - - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - - DO ij=ijb,ije - dv2(ij,1)=0. - dv1(ij,llm)=0. - ENDDO - - ijb=ij_begin - ije=ij_end - - DO ij=ijb,ije - dteta2(ij,1)=0. - dteta1(ij,llm)=0. - ENDDO -!$OMP END MASTER -!$OMP BARRIER - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - - ijb=ij_begin - ije=ij_end - if (pole_nord) ijb=ijb+iip1 - if (pole_sud) ije=ije-iip1 - - ! DO ij = iip2, ip1jmp1 - ! uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) - ! ENDDO - - ! DO ij = iip2, ip1jm - ! uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) - ! ENDDO - - DO ij = ijb, ije - - uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) & - +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) - ENDDO - - if (pole_nord) then - DO ij = 1, iip1 - uav(ij ,l) = 0. - ENDDO - endif - - if (pole_sud) then - DO ij = 1, iip1 - uav(ip1jm+ij,l) = 0. - ENDDO - endif - - ENDDO -!$OMP END DO - ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) - - !------------------ -xx ---------------------------------------------- - ! . Calcul de v - - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - - DO ij = ijb+1, ije - vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) - ENDDO - - DO ij = ijb,ije,iip1 - vav(ij,l) = vav(ij+iim,l) - ENDDO - - - DO ij = ijb, ije-1 - vav(ij,l) = vav(ij,l) + vav(ij+1,l) - ENDDO - - DO ij = ijb, ije, iip1 - vav(ij+iim,l) = vav(ij,l) - ENDDO - - ENDDO -!$OMP END DO - ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) - - !----------------------------------------------------------------------- -!$OMP BARRIER - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llmm1 - - - ! ...... calcul de - w/2. au niveau l+1 ....... - ijb=ij_begin - ije=ij_end+iip1 - if (pole_sud) ije=ij_end - - DO ij = ijb, ije - wsur2( ij ) = - 0.5 * w( ij,l+1 ) - END DO - - - ! ..................... calcul pour du .................. - - ijb=ij_begin - ije=ij_end - if (pole_nord) ijb=ijb+iip1 - if (pole_sud) ije=ije-iip1 - - DO ij = ijb ,ije-1 - ww = wsur2 ( ij ) + wsur2( ij+1 ) - uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) - du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) - du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) - END DO - - ! ................. calcul pour dv ..................... - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - - DO ij = ijb, ije - ww = wsur2( ij+iip1 ) + wsur2( ij ) - vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) - dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) - dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) - END DO - - ! - - ! ............................................................ - ! ............... calcul pour dh ................... - ! ............................................................ - - ! ---z - ! calcul de - d( teta * w ) qu'on ajoute a dh - ! ............... - ijb=ij_begin - ije=ij_end - - DO ij = ijb, ije - ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) - dteta1(ij, l ) = ww - dteta2(ij,l+1) = ww - END DO - - ! ym ---> conser a voir plus tard - - ! IF( conser) THEN - ! - ! DO 17 ij = 1,ip1jmp1 - ! ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) - ! 17 CONTINUE - ! gt = SSUM( ip1jmp1,ge,1 ) - ! gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) - ! END IF - - END DO -!$OMP END DO - - ijb=ij_begin - ije=ij_end - if (pole_nord) ijb=ijb+iip1 - if (pole_sud) ije=ije-iip1 -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('du_bis',du) -END IF -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije-1 - du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l) - ENDDO - - DO ij = ijb+iip1-1, ije, iip1 - du( ij, l ) = du( ij -iim, l ) - ENDDO - ENDDO -!$OMP END DO NOWAIT -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('du1',du1) - CALL WriteField_u('du2',du2) - CALL WriteField_u('du_bis',du) -END IF - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije - dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l) - ENDDO - ENDDO -!$OMP END DO NOWAIT - ijb=ij_begin - ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije - dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l) - ENDDO - ENDDO -!$OMP END DO NOWAIT - - RETURN -END SUBROUTINE advect_new_loc Index: LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90 (revision 5268) @@ -0,0 +1,294 @@ +! +! $Header$ +! +SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, & + du,dv,dteta) + USE parallel_lmdz + USE write_field_loc + USE advect_new_mod + USE comconst_mod, ONLY: daysec + USE logic_mod, ONLY: conser + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + IMPLICIT NONE + !======================================================================= + ! + ! Auteurs: P. Le Van , Fr. Hourdin . + ! ------- + ! + ! Objet: + ! ------ + ! + ! ************************************************************* + ! .... calcul des termes d'advection vertic.pour u,v,teta,q ... + ! ************************************************************* + ! ces termes sont ajoutes a du,dv,dteta et dq . + ! Modif F.Forget 03/94 : on retire q de advect + ! + !======================================================================= + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + include "dimensions.h" + include "paramet.h" + include "comgeom.h" + + ! Arguments: + ! ---------- + + REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL :: teta(ijb_u:ije_u,llm) + REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm) + REAL :: w(ijb_u:ije_u,llm) + REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm) + REAL :: dteta(ijb_u:ije_u,llm) + ! Local: + ! ------ + + REAL :: wsur2(ijb_u:ije_u) + REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u) + REAL :: deuxjour, ww, gt, uu, vv + + INTEGER :: ij,l,ijb,ije + EXTERNAL SSUM + REAL :: SSUM + + + + !----------------------------------------------------------------------- + ! 2. Calculs preliminaires: + ! ------------------------- + + IF (conser.AND.1==0) THEN + deuxjour = 2. * daysec + + DO ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + END DO + END IF + + + !------------------ -yy ---------------------------------------------- + ! . Calcul de u + +!$OMP MASTER + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij=ijb,ije + du2(ij,1)=0. + du1(ij,llm)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dv2(ij,1)=0. + dv1(ij,llm)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + + DO ij=ijb,ije + dteta2(ij,1)=0. + dteta1(ij,llm)=0. + ENDDO +!$OMP END MASTER +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + ! DO ij = iip2, ip1jmp1 + ! uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) + ! ENDDO + + ! DO ij = iip2, ip1jm + ! uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) + ! ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) & + +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO +!$OMP END DO + ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + + !------------------ -xx ---------------------------------------------- + ! . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +!$OMP END DO + ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) + + !----------------------------------------------------------------------- +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmm1 + + + ! ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + END DO + + + ! ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + END DO + + ! ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + END DO + + ! + + ! ............................................................ + ! ............... calcul pour dh ................... + ! ............................................................ + + ! ---z + ! calcul de - d( teta * w ) qu'on ajoute a dh + ! ............... + ijb=ij_begin + ije=ij_end + + DO ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta1(ij, l ) = ww + dteta2(ij,l+1) = ww + END DO + + ! ym ---> conser a voir plus tard + + ! IF( conser) THEN + ! + ! DO 17 ij = 1,ip1jmp1 + ! ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) + ! 17 CONTINUE + ! gt = SSUM( ip1jmp1,ge,1 ) + ! gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) + ! END IF + + END DO +!$OMP END DO + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('du_bis',du) +END IF +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l) + ENDDO + + DO ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + ENDDO + ENDDO +!$OMP END DO NOWAIT +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('du1',du1) + CALL WriteField_u('du2',du2) + CALL WriteField_u('du_bis',du) +END IF + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l) + ENDDO + ENDDO +!$OMP END DO NOWAIT + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l) + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN +END SUBROUTINE advect_new_loc Index: LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.F90 (revision 5267) +++ (revision ) @@ -1,55 +1,0 @@ -MODULE advect_new_mod - - REAL,POINTER,SAVE :: dv1(:,:) - REAL,POINTER,SAVE :: du1(:,:) - REAL,POINTER,SAVE :: dteta1(:,:) - REAL,POINTER,SAVE :: dv2(:,:) - REAL,POINTER,SAVE :: du2(:,:) - REAL,POINTER,SAVE :: dteta2(:,:) - REAL,POINTER,SAVE :: uav(:,:) - REAL,POINTER,SAVE :: vav(:,:) - - -CONTAINS - - SUBROUTINE advect_new_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - TYPE(distrib),POINTER :: d - - - d=>distrib_caldyn - CALL allocate_v(dv1,llm,d) - CALL allocate_u(du1,llm,d) - CALL allocate_u(dteta1,llm,d) - CALL allocate_v(dv2,llm,d) - CALL allocate_u(du2,llm,d) - CALL allocate_u(dteta2,llm,d) - CALL allocate_u(uav,llm,d) - CALL allocate_v(vav,llm,d) - - - END SUBROUTINE advect_new_allocate - - SUBROUTINE advect_new_switch_caldyn(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_v(dv1,distrib_caldyn,dist) - CALL switch_u(du1,distrib_caldyn,dist) - CALL switch_u(dteta1,distrib_caldyn,dist) - CALL switch_v(dv2,distrib_caldyn,dist) - CALL switch_u(du2,distrib_caldyn,dist) - CALL switch_u(dteta2,distrib_caldyn,dist) - CALL switch_u(uav,distrib_caldyn,dist) - CALL switch_v(vav,distrib_caldyn,dist) - - END SUBROUTINE advect_new_switch_caldyn - -END MODULE advect_new_mod Index: LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90 (revision 5268) @@ -0,0 +1,55 @@ +MODULE advect_new_mod + + REAL,POINTER,SAVE :: dv1(:,:) + REAL,POINTER,SAVE :: du1(:,:) + REAL,POINTER,SAVE :: dteta1(:,:) + REAL,POINTER,SAVE :: dv2(:,:) + REAL,POINTER,SAVE :: du2(:,:) + REAL,POINTER,SAVE :: dteta2(:,:) + REAL,POINTER,SAVE :: uav(:,:) + REAL,POINTER,SAVE :: vav(:,:) + + +CONTAINS + + SUBROUTINE advect_new_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_v(dv1,llm,d) + CALL allocate_u(du1,llm,d) + CALL allocate_u(dteta1,llm,d) + CALL allocate_v(dv2,llm,d) + CALL allocate_u(du2,llm,d) + CALL allocate_u(dteta2,llm,d) + CALL allocate_u(uav,llm,d) + CALL allocate_v(vav,llm,d) + + + END SUBROUTINE advect_new_allocate + + SUBROUTINE advect_new_switch_caldyn(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_v(dv1,distrib_caldyn,dist) + CALL switch_u(du1,distrib_caldyn,dist) + CALL switch_u(dteta1,distrib_caldyn,dist) + CALL switch_v(dv2,distrib_caldyn,dist) + CALL switch_u(du2,distrib_caldyn,dist) + CALL switch_u(dteta2,distrib_caldyn,dist) + CALL switch_u(uav,distrib_caldyn,dist) + CALL switch_v(vav,distrib_caldyn,dist) + + END SUBROUTINE advect_new_switch_caldyn + +END MODULE advect_new_mod Index: LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.F90 (revision 5267) +++ (revision ) @@ -1,290 +1,0 @@ - -SUBROUTINE advtrac_loc(pbarug, pbarvg, wg, p, massem, q, teta, pk) - ! Auteur : F. Hourdin - ! - ! Modif. P. Le Van (20/12/97) - ! F. Codron (10/99) - ! D. Le Croller (07/2001) - ! M.A Filiberti (04/2002) - ! - USE infotrac, ONLY: nqtot, tracers - USE control_mod, ONLY: iapp_tracvl, day_step, planet_type - USE comconst_mod, ONLY: dtvr - USE parallel_lmdz - USE Write_Field_loc - USE Write_Field - USE Bands - USE mod_hallo - USE Vampir - USE times - USE advtrac_mod, ONLY: finmasse - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - USE strings_mod, ONLY: int2str - IMPLICIT NONE - ! - include "dimensions.h" - include "paramet.h" - include "comdissip.h" - include "comgeom2.h" - include "description.h" -! include "iniprint.h" - - !--------------------------------------------------------------------------- - ! Arguments - !--------------------------------------------------------------------------- - REAL, INTENT(IN) :: pbarug(ijb_u:ije_u,llm) - REAL, INTENT(IN) :: pbarvg(ijb_v:ije_v,llm) - REAL, INTENT(IN) :: wg(ijb_u:ije_u,llm) - REAL, INTENT(IN) :: p(ijb_u:ije_u,llmp1) - REAL, INTENT(IN) :: massem(ijb_u:ije_u,llm) - REAL, INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot) - REAL, INTENT(IN) :: teta(ijb_u:ije_u,llm) - REAL, INTENT(IN) :: pk(ijb_u:ije_u,llm) - !--------------------------------------------------------------------------- - ! Ajout PPM - !--------------------------------------------------------------------------- - REAL :: massebx(ijb_u:ije_u,llm), masseby(ijb_v:ije_v,llm) - !--------------------------------------------------------------------------- - ! Variables locales - !--------------------------------------------------------------------------- - INTEGER :: ij, l, iq, iadv - REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu - REAL :: zdp(ijb_u:ije_u), zdpmin, zdpmax - INTEGER, SAVE :: iadvtr=0 -!$OMP THREADPRIVATE(iadvtr) - EXTERNAL minmax - - !--------------------------------------------------------------------------- - ! Rajouts pour PPM - !--------------------------------------------------------------------------- - INTEGER :: indice, n - REAL :: dtbon ! Pas de temps adaptatif pour que CFL<1 - REAL :: CFLmaxz, aaa, bbb ! CFL maximum - REAL, DIMENSION(iim,jjb_u:jje_u,llm) :: unatppm, vnatppm, fluxwppm - REAL :: qppm(iim*jjnb_u,llm,nqtot) - REAL :: psppm(iim,jjb_u:jje_u) ! pression au sol - REAL, DIMENSION(llmp1) :: apppm, bpppm - LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE. - INTEGER :: ijb, ije, ijbu, ijbv, ijeu, ijev, j - TYPE(Request),SAVE :: testRequest -!$OMP THREADPRIVATE(testRequest) - -! Test sur l'eventuelle creation de valeurs negatives de la masse - ijb = ij_begin; IF(pole_nord) ijb = ij_begin+iip1 - ije = ij_end; IF(pole_sud) ije = ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm-1 - DO ij = ijb+1,ije - zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) & - - pbarvg(ij-iip1,l) + pbarvg(ij,l) & - + wg(ij,l+1) - wg(ij,l) - END DO -! ym ---> pourquoi jjm-1 et non jjm ? a cause du pole ? -! CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) - DO ij = ijb,ije-iip1+1,iip1 - zdp(ij)=zdp(ij+iip1-1) - END DO - DO ij = ijb,ije - zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) - END DO -! CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) -! ym ---> eventuellement a revoir - CALL minmax( ije-ijb+1, zdp(ijb), zdpmin,zdpmax ) - IF(MAX(ABS(zdpmin),ABS(zdpmax)) >0.5) & - WRITE(*,*)'WARNING DP/P l=',l,' MIN:',zdpmin,' MAX:', zdpmax - END DO -!$OMP END DO NOWAIT - - !--------------------------------------------------------------------------- - ! Advection proprement dite (Modification Le Croller (07/2001) - !--------------------------------------------------------------------------- - - !--------------------------------------------------------------------------- - ! Calcul des moyennes basees sur la masse - !--------------------------------------------------------------------------- -!ym CALL massbar_p(massem,massebx,masseby) -!ym ----> Normalement, inutile pour les schemas classiques -!ym ----> Reverifier lors de la parallelisation des autres schemas - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('massem',massem) - CALL WriteField_u('wg',wg) - CALL WriteField_u('pbarug',pbarug) - CALL WriteField_v('pbarvg',pbarvg) - CALL WriteField_u('p_tmp',p) - CALL WriteField_u('pk_tmp',pk) - CALL WriteField_u('teta_tmp',teta) - DO iq=1,nqtot - CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq)) - END DO -END IF - -! -! CALL Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest) -! CALL SendRequest(TestRequest) -!!$OMP BARRIER -! CALL WaitRequest(TestRequest) -!$OMP BARRIER - -! WRITE(*,*) 'advtrac 157: appel de vlspltgen_loc' - CALL vlspltgen_loc(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta ) - -IF (CPPKEY_DEBUGIO) THEN - DO iq = 1, nqtot - CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq)) - END DO -END IF - - GOTO 1234 - !------------------------------------------------------------------------- - ! Appel des sous programmes d'advection - !------------------------------------------------------------------------- - DO iq = 1, nqtot -! CALL clock(t_initial) - IF(tracers(iq)%parent /= 'air') CYCLE - iadv = tracers(iq)%iadv - !----------------------------------------------------------------------- - SELECT CASE(iadv) - !----------------------------------------------------------------------- - CASE(0); CYCLE - !-------------------------------------------------------------------- - CASE(10) !--- Schema de Van Leer I MUSCL - !-------------------------------------------------------------------- -! WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:) -!LF CALL vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) - - !-------------------------------------------------------------------- - CASE(14) !--- Schema "pseuDO amont" + test sur humidite specifique - !--- pour la vapeur d'eau. F. Codron - !-------------------------------------------------------------------- -! WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:) - CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1) -!LF CALL vlspltqs_p(q(1,1,1),2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta ) - - !-------------------------------------------------------------------- - CASE(12) !--- Schema de Frederic Hourdin - !-------------------------------------------------------------------- - CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1) - CALL adaptdt(iadv,dtbon,n,pbarug,massem) ! pas de temps adaptatif - IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n - DO indice=1,n - CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) - END DO - - !-------------------------------------------------------------------- - CASE(13) !--- Pas de temps adaptatif - !-------------------------------------------------------------------- - CALL abort_gcm("advtrac","schema non parallelise",1) - CALL adaptdt(iadv,dtbon,n,pbarug,massem) - IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n - DO indice=1,n - CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) - END DO - - !-------------------------------------------------------------------- - CASE(20) !--- Schema de pente SLOPES - !-------------------------------------------------------------------- - CALL abort_gcm("advtrac","schema SLOPES non parallelise",1) - CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) - - !-------------------------------------------------------------------- - CASE(30) !--- Schema de Prather - !-------------------------------------------------------------------- - CALL abort_gcm("advtrac","schema prather non parallelise",1) - ! Pas de temps adaptatif - CALL adaptdt(iadv,dtbon,n,pbarug,massem) - IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n - CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon) - - !-------------------------------------------------------------------- - CASE(11,16,17,18) !--- Schemas PPM Lin et Rood - !-------------------------------------------------------------------- - CALL abort_gcm("advtrac","schema PPM non parallelise",1) - ! Test sur le flux horizontal - CALL adaptdt(iadv,dtbon,n,pbarug,massem) ! pas de temps adaptatif - IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n - ! Test sur le flux vertical - CFLmaxz=0. - DO l=2,llm - DO ij=iip2,ip1jm - aaa=wg(ij,l)*dtvr/massem(ij,l) - CFLmaxz=max(CFLmaxz,aaa) - bbb=-wg(ij,l)*dtvr/massem(ij,l-1) - CFLmaxz=max(CFLmaxz,bbb) - END DO - END DO - IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz - !---------------------------------------------------------------- - ! Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin) - !---------------------------------------------------------------- - CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, & - apppm,bpppm,massebx,masseby,pbarug,pbarvg, & - unatppm,vnatppm,psppm) - - !---------------------------------------------------------------- - DO indice=1,n !--- VL (version PPM) horiz. et PPM vert. - !---------------------------------------------------------------- - SELECT CASE(iadv) - !---------------------------------------------------------- - CASE(11) - !---------------------------------------------------------- - CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & - 2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) - !---------------------------------------------------------- - CASE(16) !--- Monotonic PPM - !---------------------------------------------------------- - CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & - 3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) - !---------------------------------------------------------- - CASE(17) !--- Semi monotonic PPM - !---------------------------------------------------------- - CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & - 4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.) - !---------------------------------------------------------- - CASE(18) !--- Positive Definite PPM - !---------------------------------------------------------- - CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & - 5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) - END SELECT - !---------------------------------------------------------------- - END DO - !---------------------------------------------------------------- - ! Ss-prg interface PPM3d-LMDZ.4 - !---------------------------------------------------------------- - CALL interpost(q(1,1,iq),qppm(1,1,iq)) - !---------------------------------------------------------------------- - END SELECT - !---------------------------------------------------------------------- - - !---------------------------------------------------------------------- - ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1 - !---------------------------------------------------------------------- - ! CALL traceurpole(q(1,1,iq),massem) - - !--- Calcul du temps cpu pour un schema donne - ! CALL clock(t_final) - !ym tps_cpu=t_final-t_initial - !ym cpuadv(iq)=cpuadv(iq)+tps_cpu - - END DO - -1234 CONTINUE -!$OMP BARRIER - IF(planet_type=="earth") THEN - ijb=ij_begin - ije=ij_end -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llm - DO ij = ijb, ije - finmasse(ij,l) = p(ij,l) - p(ij,l+1) - END DO - END DO -!$OMP END DO - - CALL qminimum_loc( q, nqtot, finmasse ) - - END IF ! of if (planet_type=="earth") - -END SUBROUTINE advtrac_loc - Index: LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90 (revision 5268) @@ -0,0 +1,290 @@ + +SUBROUTINE advtrac_loc(pbarug, pbarvg, wg, p, massem, q, teta, pk) + ! Auteur : F. Hourdin + ! + ! Modif. P. Le Van (20/12/97) + ! F. Codron (10/99) + ! D. Le Croller (07/2001) + ! M.A Filiberti (04/2002) + ! + USE infotrac, ONLY: nqtot, tracers + USE control_mod, ONLY: iapp_tracvl, day_step, planet_type + USE comconst_mod, ONLY: dtvr + USE parallel_lmdz + USE Write_Field_loc + USE Write_Field + USE Bands + USE mod_hallo + USE Vampir + USE times + USE advtrac_mod, ONLY: finmasse + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + USE strings_mod, ONLY: int2str + IMPLICIT NONE + ! + include "dimensions.h" + include "paramet.h" + include "comdissip.h" + include "comgeom2.h" + include "description.h" +! include "iniprint.h" + + !--------------------------------------------------------------------------- + ! Arguments + !--------------------------------------------------------------------------- + REAL, INTENT(IN) :: pbarug(ijb_u:ije_u,llm) + REAL, INTENT(IN) :: pbarvg(ijb_v:ije_v,llm) + REAL, INTENT(IN) :: wg(ijb_u:ije_u,llm) + REAL, INTENT(IN) :: p(ijb_u:ije_u,llmp1) + REAL, INTENT(IN) :: massem(ijb_u:ije_u,llm) + REAL, INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot) + REAL, INTENT(IN) :: teta(ijb_u:ije_u,llm) + REAL, INTENT(IN) :: pk(ijb_u:ije_u,llm) + !--------------------------------------------------------------------------- + ! Ajout PPM + !--------------------------------------------------------------------------- + REAL :: massebx(ijb_u:ije_u,llm), masseby(ijb_v:ije_v,llm) + !--------------------------------------------------------------------------- + ! Variables locales + !--------------------------------------------------------------------------- + INTEGER :: ij, l, iq, iadv + REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu + REAL :: zdp(ijb_u:ije_u), zdpmin, zdpmax + INTEGER, SAVE :: iadvtr=0 +!$OMP THREADPRIVATE(iadvtr) + EXTERNAL minmax + + !--------------------------------------------------------------------------- + ! Rajouts pour PPM + !--------------------------------------------------------------------------- + INTEGER :: indice, n + REAL :: dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL :: CFLmaxz, aaa, bbb ! CFL maximum + REAL, DIMENSION(iim,jjb_u:jje_u,llm) :: unatppm, vnatppm, fluxwppm + REAL :: qppm(iim*jjnb_u,llm,nqtot) + REAL :: psppm(iim,jjb_u:jje_u) ! pression au sol + REAL, DIMENSION(llmp1) :: apppm, bpppm + LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE. + INTEGER :: ijb, ije, ijbu, ijbv, ijeu, ijev, j + TYPE(Request),SAVE :: testRequest +!$OMP THREADPRIVATE(testRequest) + +! Test sur l'eventuelle creation de valeurs negatives de la masse + ijb = ij_begin; IF(pole_nord) ijb = ij_begin+iip1 + ije = ij_end; IF(pole_sud) ije = ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm-1 + DO ij = ijb+1,ije + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) & + - pbarvg(ij-iip1,l) + pbarvg(ij,l) & + + wg(ij,l+1) - wg(ij,l) + END DO +! ym ---> pourquoi jjm-1 et non jjm ? a cause du pole ? +! CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) + DO ij = ijb,ije-iip1+1,iip1 + zdp(ij)=zdp(ij+iip1-1) + END DO + DO ij = ijb,ije + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + END DO +! CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) +! ym ---> eventuellement a revoir + CALL minmax( ije-ijb+1, zdp(ijb), zdpmin,zdpmax ) + IF(MAX(ABS(zdpmin),ABS(zdpmax)) >0.5) & + WRITE(*,*)'WARNING DP/P l=',l,' MIN:',zdpmin,' MAX:', zdpmax + END DO +!$OMP END DO NOWAIT + + !--------------------------------------------------------------------------- + ! Advection proprement dite (Modification Le Croller (07/2001) + !--------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! Calcul des moyennes basees sur la masse + !--------------------------------------------------------------------------- +!ym CALL massbar_p(massem,massebx,masseby) +!ym ----> Normalement, inutile pour les schemas classiques +!ym ----> Reverifier lors de la parallelisation des autres schemas + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('massem',massem) + CALL WriteField_u('wg',wg) + CALL WriteField_u('pbarug',pbarug) + CALL WriteField_v('pbarvg',pbarvg) + CALL WriteField_u('p_tmp',p) + CALL WriteField_u('pk_tmp',pk) + CALL WriteField_u('teta_tmp',teta) + DO iq=1,nqtot + CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq)) + END DO +END IF + +! +! CALL Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest) +! CALL SendRequest(TestRequest) +!!$OMP BARRIER +! CALL WaitRequest(TestRequest) +!$OMP BARRIER + +! WRITE(*,*) 'advtrac 157: appel de vlspltgen_loc' + CALL vlspltgen_loc(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta ) + +IF (CPPKEY_DEBUGIO) THEN + DO iq = 1, nqtot + CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq)) + END DO +END IF + + GOTO 1234 + !------------------------------------------------------------------------- + ! Appel des sous programmes d'advection + !------------------------------------------------------------------------- + DO iq = 1, nqtot +! CALL clock(t_initial) + IF(tracers(iq)%parent /= 'air') CYCLE + iadv = tracers(iq)%iadv + !----------------------------------------------------------------------- + SELECT CASE(iadv) + !----------------------------------------------------------------------- + CASE(0); CYCLE + !-------------------------------------------------------------------- + CASE(10) !--- Schema de Van Leer I MUSCL + !-------------------------------------------------------------------- +! WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:) +!LF CALL vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + + !-------------------------------------------------------------------- + CASE(14) !--- Schema "pseuDO amont" + test sur humidite specifique + !--- pour la vapeur d'eau. F. Codron + !-------------------------------------------------------------------- +! WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:) + CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1) +!LF CALL vlspltqs_p(q(1,1,1),2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta ) + + !-------------------------------------------------------------------- + CASE(12) !--- Schema de Frederic Hourdin + !-------------------------------------------------------------------- + CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1) + CALL adaptdt(iadv,dtbon,n,pbarug,massem) ! pas de temps adaptatif + IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n + DO indice=1,n + CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + END DO + + !-------------------------------------------------------------------- + CASE(13) !--- Pas de temps adaptatif + !-------------------------------------------------------------------- + CALL abort_gcm("advtrac","schema non parallelise",1) + CALL adaptdt(iadv,dtbon,n,pbarug,massem) + IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n + DO indice=1,n + CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + END DO + + !-------------------------------------------------------------------- + CASE(20) !--- Schema de pente SLOPES + !-------------------------------------------------------------------- + CALL abort_gcm("advtrac","schema SLOPES non parallelise",1) + CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + + !-------------------------------------------------------------------- + CASE(30) !--- Schema de Prather + !-------------------------------------------------------------------- + CALL abort_gcm("advtrac","schema prather non parallelise",1) + ! Pas de temps adaptatif + CALL adaptdt(iadv,dtbon,n,pbarug,massem) + IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n + CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon) + + !-------------------------------------------------------------------- + CASE(11,16,17,18) !--- Schemas PPM Lin et Rood + !-------------------------------------------------------------------- + CALL abort_gcm("advtrac","schema PPM non parallelise",1) + ! Test sur le flux horizontal + CALL adaptdt(iadv,dtbon,n,pbarug,massem) ! pas de temps adaptatif + IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n + ! Test sur le flux vertical + CFLmaxz=0. + DO l=2,llm + DO ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + END DO + END DO + IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + !---------------------------------------------------------------- + ! Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin) + !---------------------------------------------------------------- + CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, & + apppm,bpppm,massebx,masseby,pbarug,pbarvg, & + unatppm,vnatppm,psppm) + + !---------------------------------------------------------------- + DO indice=1,n !--- VL (version PPM) horiz. et PPM vert. + !---------------------------------------------------------------- + SELECT CASE(iadv) + !---------------------------------------------------------- + CASE(11) + !---------------------------------------------------------- + CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & + 2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) + !---------------------------------------------------------- + CASE(16) !--- Monotonic PPM + !---------------------------------------------------------- + CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & + 3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) + !---------------------------------------------------------- + CASE(17) !--- Semi monotonic PPM + !---------------------------------------------------------- + CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & + 4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.) + !---------------------------------------------------------- + CASE(18) !--- Positive Definite PPM + !---------------------------------------------------------- + CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, & + 5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.) + END SELECT + !---------------------------------------------------------------- + END DO + !---------------------------------------------------------------- + ! Ss-prg interface PPM3d-LMDZ.4 + !---------------------------------------------------------------- + CALL interpost(q(1,1,iq),qppm(1,1,iq)) + !---------------------------------------------------------------------- + END SELECT + !---------------------------------------------------------------------- + + !---------------------------------------------------------------------- + ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1 + !---------------------------------------------------------------------- + ! CALL traceurpole(q(1,1,iq),massem) + + !--- Calcul du temps cpu pour un schema donne + ! CALL clock(t_final) + !ym tps_cpu=t_final-t_initial + !ym cpuadv(iq)=cpuadv(iq)+tps_cpu + + END DO + +1234 CONTINUE +!$OMP BARRIER + IF(planet_type=="earth") THEN + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + END DO + END DO +!$OMP END DO + + CALL qminimum_loc( q, nqtot, finmasse ) + + END IF ! of if (planet_type=="earth") + +END SUBROUTINE advtrac_loc + Index: LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.F90 (revision 5267) +++ (revision ) @@ -1,36 +1,0 @@ -MODULE advtrac_mod - - REAL,POINTER,SAVE :: finmasse(:,:) - -CONTAINS - - SUBROUTINE advtrac_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE vlspltgen_mod - IMPLICIT NONE - INCLUDE "dimensions.h" - INCLUDE "paramet.h" - TYPE(distrib),POINTER :: d - - d=>distrib_vanleer - CALL allocate_u(finmasse,llm,d) - CALL vlspltgen_allocate - END SUBROUTINE advtrac_allocate - - SUBROUTINE advtrac_switch_vanleer(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE vlspltgen_mod - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_u(finmasse,distrib_vanleer,dist) - - CALL vlspltgen_switch_vanleer(dist) - - END SUBROUTINE advtrac_switch_vanleer - -END MODULE advtrac_mod Index: LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90 (revision 5268) @@ -0,0 +1,36 @@ +MODULE advtrac_mod + + REAL,POINTER,SAVE :: finmasse(:,:) + +CONTAINS + + SUBROUTINE advtrac_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE vlspltgen_mod + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(finmasse,llm,d) + CALL vlspltgen_allocate + END SUBROUTINE advtrac_allocate + + SUBROUTINE advtrac_switch_vanleer(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE vlspltgen_mod + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(finmasse,distrib_vanleer,dist) + + CALL vlspltgen_switch_vanleer(dist) + + END SUBROUTINE advtrac_switch_vanleer + +END MODULE advtrac_mod Index: LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.F90 (revision 5267) +++ (revision ) @@ -1,739 +1,0 @@ -MODULE allocate_field_mod - - INTERFACE allocate_u - MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d - END INTERFACE allocate_u - - INTERFACE switch_u - MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d - END INTERFACE switch_u - - INTERFACE switch_v - MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d - END INTERFACE switch_v - - INTERFACE allocate_v - MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d - END INTERFACE allocate_v - - INTERFACE allocate2d_u - MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d - END INTERFACE allocate2d_u - - INTERFACE allocate2d_v - MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d - END INTERFACE allocate2d_v - - INTERFACE switch2d_u - MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d - END INTERFACE switch2d_u - - INTERFACE switch2d_v - MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d - END INTERFACE switch2D_v - - REAL :: nan - -CONTAINS - - SUBROUTINE Init_nan - IMPLICIT NONE - REAL*8 :: rnan - INTEGER :: inan(2) - EQUIVALENCE(rnan,inan) - - inan(1)=2147483647 - inan(2)=2147483647 - - nan=rnan - - END SUBROUTINE Init_nan - - SUBROUTINE allocate1d_u1d(field,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:) - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_u:d%ije_u)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate1d_u1d - - - SUBROUTINE allocate2d_u1d(field,dim1,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:,:) - INTEGER :: dim1 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_u:d%ije_u,dim1)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate2d_u1d - - SUBROUTINE allocate3d_u1d(field,dim1,dim2,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - INTEGER :: dim1,dim2 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate3d_u1d - - - - SUBROUTINE allocate1d_v1d(field,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:) - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_v:d%ije_v)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate1d_v1d - - - SUBROUTINE allocate2d_v1d(field,dim1,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:,:) - INTEGER :: dim1 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_v:d%ije_v,dim1)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate2d_v1d - - SUBROUTINE allocate3d_v1d(field,dim1,dim2,d) - USE parallel_lmdz - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - INTEGER :: dim1,dim2 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate3d_v1d - - - - - - - - - - SUBROUTINE allocate1d_u2d(field,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_u:d%jje_u)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate1d_u2d - - - SUBROUTINE allocate2d_u2d(field,dim1,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - INTEGER :: dim1 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate2d_u2d - - SUBROUTINE allocate3d_u2d(field,dim1,dim2,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:,:) - INTEGER :: dim1,dim2 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate3d_u2d - - - - SUBROUTINE allocate1d_v2d(field,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_v:d%jje_v)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate1d_v2d - - - SUBROUTINE allocate2d_v2d(field,dim1,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - INTEGER :: dim1 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate2d_v2d - - SUBROUTINE allocate3d_v2d(field,dim1,dim2,d) - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:,:) - INTEGER :: dim1,dim2 - TYPE(distrib),INTENT(IN) :: d - -!$OMP BARRIER -!$OMP MASTER - IF (ASSOCIATED(field)) DEALLOCATE(field) - ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2)) -!$OMP END MASTER -!$OMP BARRIER - - END SUBROUTINE allocate3d_v2d - - - - - - - - - - - - - - - - - - - - SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u)) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - - CALL barrier - END SUBROUTINE switch1d_u1d - - SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch2d_u1d - - SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch3d_u1d - - - - - SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v)) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - - CALL barrier - END SUBROUTINE switch1d_v1d - - SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch2d_v1d - - SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch3d_v1d - - - - - - - - - - - - - SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u)) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch1d_u2d - - SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch2d_u2d - - SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch3d_u2d - - - - - SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v)) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - CALL barrier - - END SUBROUTINE switch1d_v2d - - SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - - CALL barrier - END SUBROUTINE switch2d_v2d - - SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down) - USE parallel_lmdz - USE mod_hallo - USE dimensions_mod - IMPLICIT NONE - REAL,POINTER :: field(:,:,:,:) - TYPE(distrib),INTENT(IN) :: old_dist - TYPE(distrib),INTENT(IN) :: new_dist - INTEGER, OPTIONAL,INTENT(IN) :: up - INTEGER, OPTIONAL,INTENT(IN) :: down - - REAL,POINTER,SAVE :: new_field(:,:,:,:) - TYPE(request) :: req - - !$OMP BARRIER - !$OMP MASTER - ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4))) - new_field=nan - !$OMP END MASTER - !$OMP BARRIER - CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) - - CALL SendRequest(req) - - !$OMP BARRIER - CALL WaitRequest(req) - !$OMP BARRIER - - !$OMP MASTER - DEALLOCATE(field) - field=>new_field - !$OMP END MASTER - !$OMP BARRIER - - CALL barrier - END SUBROUTINE switch3d_v2d - -END MODULE allocate_field_mod - - - - Index: LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90 (revision 5268) @@ -0,0 +1,739 @@ +MODULE allocate_field_mod + + INTERFACE allocate_u + MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d + END INTERFACE allocate_u + + INTERFACE switch_u + MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d + END INTERFACE switch_u + + INTERFACE switch_v + MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d + END INTERFACE switch_v + + INTERFACE allocate_v + MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d + END INTERFACE allocate_v + + INTERFACE allocate2d_u + MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d + END INTERFACE allocate2d_u + + INTERFACE allocate2d_v + MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d + END INTERFACE allocate2d_v + + INTERFACE switch2d_u + MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d + END INTERFACE switch2d_u + + INTERFACE switch2d_v + MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d + END INTERFACE switch2D_v + + REAL :: nan + +CONTAINS + + SUBROUTINE Init_nan + IMPLICIT NONE + REAL*8 :: rnan + INTEGER :: inan(2) + EQUIVALENCE(rnan,inan) + + inan(1)=2147483647 + inan(2)=2147483647 + + nan=rnan + + END SUBROUTINE Init_nan + + SUBROUTINE allocate1d_u1d(field,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_u1d + + + SUBROUTINE allocate2d_u1d(field,dim1,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_u1d + + SUBROUTINE allocate3d_u1d(field,dim1,dim2,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_u1d + + + + SUBROUTINE allocate1d_v1d(field,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_v1d + + + SUBROUTINE allocate2d_v1d(field,dim1,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_v1d + + SUBROUTINE allocate3d_v1d(field,dim1,dim2,d) + USE parallel_lmdz + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_v1d + + + + + + + + + + SUBROUTINE allocate1d_u2d(field,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_u2d + + + SUBROUTINE allocate2d_u2d(field,dim1,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_u2d + + SUBROUTINE allocate3d_u2d(field,dim1,dim2,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_u2d + + + + SUBROUTINE allocate1d_v2d(field,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_v2d + + + SUBROUTINE allocate2d_v2d(field,dim1,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_v2d + + SUBROUTINE allocate3d_v2d(field,dim1,dim2,d) + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_v2d + + + + + + + + + + + + + + + + + + + + SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch1d_u1d + + SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_u1d + + SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_u1d + + + + + SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch1d_v1d + + SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_v1d + + SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_v1d + + + + + + + + + + + + + SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch1d_u2d + + SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_u2d + + SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_u2d + + + + + SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch1d_v2d + + SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch2d_v2d + + SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down) + USE parallel_lmdz + USE mod_hallo + USE dimensions_mod + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch3d_v2d + +END MODULE allocate_field_mod + + + + Index: LMDZ6/trunk/libf/dyn3dmem/bands.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/bands.F90 (revision 5267) +++ (revision ) @@ -1,490 +1,0 @@ -! -! $Id$ -! - module Bands - USE parallel_lmdz - integer, parameter :: bands_caldyn=1 - integer, parameter :: bands_vanleer=2 - integer, parameter :: bands_dissip=3 - - INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn - INTEGER,dimension(:),allocatable :: jj_Nb_vanleer - INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2 - INTEGER,dimension(:),allocatable :: jj_Nb_dissip - INTEGER,dimension(:),allocatable :: jj_Nb_physic - INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis - - TYPE(distrib),SAVE,TARGET :: distrib_Caldyn - TYPE(distrib),SAVE,TARGET :: distrib_vanleer - TYPE(distrib),SAVE,TARGET :: distrib_vanleer2 - TYPE(distrib),SAVE,TARGET :: distrib_dissip - TYPE(distrib),SAVE,TARGET :: distrib_physic - TYPE(distrib),SAVE,TARGET :: distrib_physic_bis - - INTEGER,dimension(:),allocatable :: distrib_phys - - contains - - subroutine AllocateBands - USE parallel_lmdz - implicit none - - allocate(jj_Nb_Caldyn(0:MPI_Size-1)) - allocate(jj_Nb_vanleer(0:MPI_Size-1)) - allocate(jj_Nb_vanleer2(0:MPI_Size-1)) - allocate(jj_Nb_dissip(0:MPI_Size-1)) - allocate(jj_Nb_physic(0:MPI_Size-1)) - allocate(jj_Nb_physic_bis(0:MPI_Size-1)) - allocate(distrib_phys(0:MPI_Size-1)) - - end subroutine AllocateBands - - subroutine Read_distrib - USE parallel_lmdz - implicit none - - include "dimensions.h" - integer :: i,j - character (len=4) :: siim,sjjm,sllm,sproc - character (len=255) :: filename - integer :: unit_number=10 - integer :: ierr - - call AllocateBands - write(siim,'(i3)') iim - write(sjjm,'(i3)') jjm - write(sllm,'(i3)') llm - write(sproc,'(i3)') mpi_size - filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & - //TRIM(ADJUSTL(sproc))//'prc.dat' - - OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) - - if (ierr==0) then - - do i=0,mpi_size-1 - read (unit_number,*) j,jj_nb_caldyn(i) - enddo - - do i=0,mpi_size-1 - read (unit_number,*) j,jj_nb_vanleer(i) - enddo - - do i=0,mpi_size-1 - read (unit_number,*) j,jj_nb_dissip(i) - enddo - - do i=0,mpi_size-1 - read (unit_number,*) j,distrib_phys(i) - enddo - - CLOSE(unit_number) - - else - do i=0,mpi_size-1 - jj_nb_caldyn(i)=(jjm+1)/mpi_size - if (ivalue(j)) then - tmpvalue=value(i) - value(i)=value(j) - value(j)=tmpvalue - - tmpindex=index(i) - index(i)=index(j) - index(j)=tmpindex - endif - enddo - enddo - - maxvalue=value(mpi_size-1) - max_proc=index(mpi_size-1) - - do i=0,mpi_size-2 - minvalue=value(i) - min_proc=index(i) - if (jj_nb_caldyn(max_proc)>2) then - if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then - jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 - jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 - exit - else - if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) & - -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then - jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 - jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 - exit - endif - endif - endif - enddo - - deallocate(value) - deallocate(index) - CALL create_distrib(jj_nb_caldyn,new_dist) - - end subroutine AdjustBands_caldyn - - subroutine AdjustBands_vanleer(new_dist) - use times - USE parallel_lmdz - implicit none - TYPE(distrib),INTENT(INOUT) :: new_dist - - real :: minvalue,maxvalue - integer :: min_proc,max_proc - integer :: i,j - real,allocatable,dimension(:) :: value - integer,allocatable,dimension(:) :: index - real :: tmpvalue - integer :: tmpindex - - allocate(value(0:mpi_size-1)) - allocate(index(0:mpi_size-1)) - - - call allgather_timer_average - - do i=0,mpi_size-1 - value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i) - index(i)=i - enddo - - do i=0,mpi_size-2 - do j=i+1,mpi_size-1 - if (value(i)>value(j)) then - tmpvalue=value(i) - value(i)=value(j) - value(j)=tmpvalue - - tmpindex=index(i) - index(i)=index(j) - index(j)=tmpindex - endif - enddo - enddo - - maxvalue=value(mpi_size-1) - max_proc=index(mpi_size-1) - - do i=0,mpi_size-2 - minvalue=value(i) - min_proc=index(i) - - if (jj_nb_vanleer(max_proc)>2) then - if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. & - timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then - jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 - jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 - exit - else - if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then - jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 - jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 - exit - endif - endif - endif - enddo - - deallocate(value) - deallocate(index) - - CALL create_distrib(jj_nb_vanleer,new_dist) - - end subroutine AdjustBands_vanleer - - subroutine AdjustBands_dissip(new_dist) - use times - USE parallel_lmdz - implicit none - TYPE(distrib),INTENT(INOUT) :: new_dist - - real :: minvalue,maxvalue - integer :: min_proc,max_proc - integer :: i,j - real,allocatable,dimension(:) :: value - integer,allocatable,dimension(:) :: index - real :: tmpvalue - integer :: tmpindex - - allocate(value(0:mpi_size-1)) - allocate(index(0:mpi_size-1)) - - - call allgather_timer_average - - do i=0,mpi_size-1 - value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i) - index(i)=i - enddo - - do i=0,mpi_size-2 - do j=i+1,mpi_size-1 - if (value(i)>value(j)) then - tmpvalue=value(i) - value(i)=value(j) - value(j)=tmpvalue - - tmpindex=index(i) - index(i)=index(j) - index(j)=tmpindex - endif - enddo - enddo - - maxvalue=value(mpi_size-1) - max_proc=index(mpi_size-1) - - do i=0,mpi_size-2 - minvalue=value(i) - min_proc=index(i) - - if (jj_nb_dissip(max_proc)>3) then - if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then - jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 - jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 - exit - else - if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) & - - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then - jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 - jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 - exit - endif - endif - endif - enddo - - deallocate(value) - deallocate(index) - - CALL create_distrib(jj_nb_dissip,new_dist) - - end subroutine AdjustBands_dissip - - subroutine AdjustBands_physic - use times -! Ehouarn: what follows is only related to // physics - USE mod_phys_lmdz_para, only : klon_mpi_para_nb - - USE parallel_lmdz - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS - - implicit none - - integer :: i,Index - real,allocatable,dimension(:) :: value - integer,allocatable,dimension(:) :: Inc - real :: medium - integer :: NbTot,sgn - - allocate(value(0:mpi_size-1)) - allocate(Inc(0:mpi_size-1)) - - - call allgather_timer_average - - medium=0 - do i=0,mpi_size-1 - value(i)=timer_average(jj_nb_physic(i),timer_physic,i) - medium=medium+value(i) - enddo - - medium=medium/mpi_size - NbTot=0 -IF (CPPKEY_PHYS) THEN - do i=0,mpi_size-1 - Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i)) - NbTot=NbTot+Inc(i) - enddo - - if (NbTot>=0) then - Sgn=1 - else - Sgn=-1 - NbTot=-NbTot - endif - - Index=0 - do i=1,NbTot - Inc(Index)=Inc(Index)-Sgn - Index=Index+1 - if (Index>mpi_size-1) Index=0 - enddo - - do i=0,mpi_size-1 - distrib_phys(i)=klon_mpi_para_nb(i)+inc(i) - enddo -END IF - - end subroutine AdjustBands_physic - - subroutine WriteBands - USE parallel_lmdz - implicit none - include "dimensions.h" - - integer :: i,j - character (len=4) :: siim,sjjm,sllm,sproc - character (len=255) :: filename - integer :: unit_number=10 - integer :: ierr - - write(siim,'(i3)') iim - write(sjjm,'(i3)') jjm - write(sllm,'(i3)') llm - write(sproc,'(i3)') mpi_size - - filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & - //TRIM(ADJUSTL(sproc))//'prc.dat' - - OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr) - - if (ierr==0) then - -! write (unit_number,*) '*** Bandes caldyn ***' - do i=0,mpi_size-1 - write (unit_number,*) i,jj_nb_caldyn(i) - enddo - -! write (unit_number,*) '*** Bandes vanleer ***' - do i=0,mpi_size-1 - write (unit_number,*) i,jj_nb_vanleer(i) - enddo - -! write (unit_number,*) '*** Bandes dissip ***' - do i=0,mpi_size-1 - write (unit_number,*) i,jj_nb_dissip(i) - enddo - - do i=0,mpi_size-1 - write (unit_number,*) i,distrib_phys(i) - enddo - - CLOSE(unit_number) - else - print *,'probleme lors de l ecriture des bandes' - endif - - end subroutine WriteBands - - end module Bands - - - Index: LMDZ6/trunk/libf/dyn3dmem/bands.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/bands.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/bands.f90 (revision 5268) @@ -0,0 +1,490 @@ +! +! $Id$ +! + module Bands + USE parallel_lmdz + integer, parameter :: bands_caldyn=1 + integer, parameter :: bands_vanleer=2 + integer, parameter :: bands_dissip=3 + + INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2 + INTEGER,dimension(:),allocatable :: jj_Nb_dissip + INTEGER,dimension(:),allocatable :: jj_Nb_physic + INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis + + TYPE(distrib),SAVE,TARGET :: distrib_Caldyn + TYPE(distrib),SAVE,TARGET :: distrib_vanleer + TYPE(distrib),SAVE,TARGET :: distrib_vanleer2 + TYPE(distrib),SAVE,TARGET :: distrib_dissip + TYPE(distrib),SAVE,TARGET :: distrib_physic + TYPE(distrib),SAVE,TARGET :: distrib_physic_bis + + INTEGER,dimension(:),allocatable :: distrib_phys + + contains + + subroutine AllocateBands + USE parallel_lmdz + implicit none + + allocate(jj_Nb_Caldyn(0:MPI_Size-1)) + allocate(jj_Nb_vanleer(0:MPI_Size-1)) + allocate(jj_Nb_vanleer2(0:MPI_Size-1)) + allocate(jj_Nb_dissip(0:MPI_Size-1)) + allocate(jj_Nb_physic(0:MPI_Size-1)) + allocate(jj_Nb_physic_bis(0:MPI_Size-1)) + allocate(distrib_phys(0:MPI_Size-1)) + + end subroutine AllocateBands + + subroutine Read_distrib + USE parallel_lmdz + implicit none + + include "dimensions.h" + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + call AllocateBands + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_caldyn(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_vanleer(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,distrib_phys(i) + enddo + + CLOSE(unit_number) + + else + do i=0,mpi_size-1 + jj_nb_caldyn(i)=(jjm+1)/mpi_size + if (ivalue(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + if (jj_nb_caldyn(max_proc)>2) then + if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + else + if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) & + -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + CALL create_distrib(jj_nb_caldyn,new_dist) + + end subroutine AdjustBands_caldyn + + subroutine AdjustBands_vanleer(new_dist) + use times + USE parallel_lmdz + implicit none + TYPE(distrib),INTENT(INOUT) :: new_dist + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_vanleer(max_proc)>2) then + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. & + timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + else + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + CALL create_distrib(jj_nb_vanleer,new_dist) + + end subroutine AdjustBands_vanleer + + subroutine AdjustBands_dissip(new_dist) + use times + USE parallel_lmdz + implicit none + TYPE(distrib),INTENT(INOUT) :: new_dist + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_dissip(max_proc)>3) then + if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + else + if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) & + - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + CALL create_distrib(jj_nb_dissip,new_dist) + + end subroutine AdjustBands_dissip + + subroutine AdjustBands_physic + use times +! Ehouarn: what follows is only related to // physics + USE mod_phys_lmdz_para, only : klon_mpi_para_nb + + USE parallel_lmdz + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS + + implicit none + + integer :: i,Index + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: Inc + real :: medium + integer :: NbTot,sgn + + allocate(value(0:mpi_size-1)) + allocate(Inc(0:mpi_size-1)) + + + call allgather_timer_average + + medium=0 + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_physic(i),timer_physic,i) + medium=medium+value(i) + enddo + + medium=medium/mpi_size + NbTot=0 +IF (CPPKEY_PHYS) THEN + do i=0,mpi_size-1 + Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i)) + NbTot=NbTot+Inc(i) + enddo + + if (NbTot>=0) then + Sgn=1 + else + Sgn=-1 + NbTot=-NbTot + endif + + Index=0 + do i=1,NbTot + Inc(Index)=Inc(Index)-Sgn + Index=Index+1 + if (Index>mpi_size-1) Index=0 + enddo + + do i=0,mpi_size-1 + distrib_phys(i)=klon_mpi_para_nb(i)+inc(i) + enddo +END IF + + end subroutine AdjustBands_physic + + subroutine WriteBands + USE parallel_lmdz + implicit none + include "dimensions.h" + + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + +! write (unit_number,*) '*** Bandes caldyn ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_caldyn(i) + enddo + +! write (unit_number,*) '*** Bandes vanleer ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_vanleer(i) + enddo + +! write (unit_number,*) '*** Bandes dissip ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + write (unit_number,*) i,distrib_phys(i) + enddo + + CLOSE(unit_number) + else + print *,'probleme lors de l ecriture des bandes' + endif + + end subroutine WriteBands + + end module Bands + + + Index: LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90 (revision 5267) +++ (revision ) @@ -1,843 +1,0 @@ -! -! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $ -! -SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, & - ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) - - ! AFAIRE - ! Prevoir en champ nq+1 le diagnostique de l'energie - ! en faisant Qzon=Cv T + L * ... - ! vQ..A=Cp T + L * ... - - USE IOIPSL - USE parallel_lmdz - USE mod_hallo - use misc_mod - USE write_field_loc - USE comconst_mod, ONLY: cpp, pi - USE comvert_mod, ONLY: presnivs - USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn - - IMPLICIT NONE - - include "dimensions.h" - include "paramet.h" - include "comgeom2.h" - include "iniprint.h" - - !==================================================================== - ! - ! Sous-programme consacre � des diagnostics dynamiques de base - ! - ! - ! De facon generale, les moyennes des scalaires Q sont ponderees par - ! la masse. - ! - ! Les flux de masse sont eux simplement moyennes. - ! - !==================================================================== - - ! Arguments : - ! =========== - - integer :: ntrac - real :: dt_app,dt_cum - real :: ps(iip1,jjb_u:jje_u) - real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm) - real :: flux_u(iip1,jjb_u:jje_u,llm) - real :: flux_v(iip1,jjb_v:jje_v,llm) - real :: teta(iip1,jjb_u:jje_u,llm) - real :: phi(iip1,jjb_u:jje_u,llm) - real :: ucov(iip1,jjb_u:jje_u,llm) - real :: vcov(iip1,jjb_v:jje_v,llm) - real :: trac(iip1,jjb_u:jje_u,llm,ntrac) - - ! Local : - ! ======= - - integer,SAVE :: icum,ncum -!$OMP THREADPRIVATE(icum,ncum) - LOGICAL,SAVE :: first=.TRUE. -!$OMP THREADPRIVATE(first) - - real :: zz,zqy - REAl,SAVE,ALLOCATABLE :: zfactv(:,:) - - INTEGER,PARAMETER :: nQ=7 - - - !ym character*6 nom(nQ) - !ym character*6 unites(nQ) - character(len=6),save :: nom(nQ) - character(len=6),save :: unites(nQ) - - character(len=10) file - integer :: ifile - parameter (ifile=4) - - integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5 - INTEGER,PARAMETER :: iovap=6,iun=7 - integer,PARAMETER :: i_sortie=1 - - real,SAVE :: time=0. - integer,SAVE :: itau=0. -!$OMP THREADPRIVATE(time,itau) - - real :: ww - - ! variables dynamiques interm�diaires - REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:) - REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:) - REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:) - REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:) - REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:) - REAL,SAVE,ALLOCATABLE :: bern(:,:,:) - - ! champ contenant les scalaires advect�s. - real,SAVE,ALLOCATABLE :: Q(:,:,:,:) - - ! champs cumul�s - real,SAVE,ALLOCATABLE :: ps_cum(:,:) - real,SAVE,ALLOCATABLE :: masse_cum(:,:,:) - real,SAVE,ALLOCATABLE :: flux_u_cum(:,:,:) - real,SAVE,ALLOCATABLE :: flux_v_cum(:,:,:) - real,SAVE,ALLOCATABLE :: Q_cum(:,:,:,:) - real,SAVE,ALLOCATABLE :: flux_uQ_cum(:,:,:,:) - real,SAVE,ALLOCATABLE :: flux_vQ_cum(:,:,:,:) - real,SAVE,ALLOCATABLE :: flux_wQ_cum(:,:,:,:) - real,SAVE,ALLOCATABLE :: dQ(:,:,:,:) - - - ! champs de tansport en moyenne zonale - integer :: ntr,itr - parameter (ntr=5) - - !ym character*10 znom(ntr,nQ) - !ym character*20 znoml(ntr,nQ) - !ym character*10 zunites(ntr,nQ) - character*10,save :: znom(ntr,nQ) - character*20,save :: znoml(ntr,nQ) - character*10,save :: zunites(ntr,nQ) - - INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5 - - character(len=3) :: ctrs(ntr) - data ctrs/' ','TOT','MMC','TRS','STN'/ - - real,SAVE,ALLOCATABLE :: zvQ(:,:,:,:),zvQtmp(:,:) - real,SAVE,ALLOCATABLE :: zavQ(:,:,:),psiQ(:,:,:) - real,SAVE,ALLOCATABLE :: zmasse(:,:),zamasse(:) - - real,SAVE,ALLOCATABLE :: zv(:,:),psi(:,:) - - integer :: i,j,l,iQ - - - ! Initialisation du fichier contenant les moyennes zonales. - ! --------------------------------------------------------- - - character(len=10) :: infile - - integer, save :: fileid - integer :: thoriid, zvertiid - - INTEGER,SAVE,ALLOCATABLE :: ndex3d(:) - - ! Variables locales - ! - integer :: tau0 - real :: zjulian - character(len=3) :: str - character(len=10) :: ctrac - integer :: ii,jj - integer :: zan, dayref - ! - real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:) - integer :: jjb,jje,jjn,ijb,ije - type(Request),SAVE :: Req -!$OMP THREADPRIVATE(Req) - - ! definition du domaine d'ecriture pour le rebuild - - INTEGER,DIMENSION(1) :: ddid - INTEGER,DIMENSION(1) :: dsg - INTEGER,DIMENSION(1) :: dsl - INTEGER,DIMENSION(1) :: dpf - INTEGER,DIMENSION(1) :: dpl - INTEGER,DIMENSION(1) :: dhs - INTEGER,DIMENSION(1) :: dhe - - INTEGER :: bilan_dyn_domain_id - - !===================================================================== - ! Initialisation - !===================================================================== - if (adjust) return - - time=time+dt_app - itau=itau+1 - - if (first) then -!$OMP BARRIER -!$OMP MASTER - ALLOCATE(zfactv(jjb_v:jje_v,llm)) - ALLOCATE(vcont(iip1,jjb_v:jje_v,llm)) - ALLOCATE(ucont(iip1,jjb_u:jje_u,llm)) - ALLOCATE(ang(iip1,jjb_u:jje_u,llm)) - ALLOCATE(unat(iip1,jjb_u:jje_u,llm)) - ALLOCATE(massebx(iip1,jjb_u:jje_u,llm)) - ALLOCATE(masseby(iip1,jjb_v:jje_v,llm)) - ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm)) - ALLOCATE(w(iip1,jjb_u:jje_u,llm)) - ALLOCATE(ecin(iip1,jjb_u:jje_u,llm)) - ALLOCATE(convm(iip1,jjb_u:jje_u,llm)) - ALLOCATE(bern(iip1,jjb_u:jje_u,llm)) - ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ)) - ALLOCATE(ps_cum(iip1,jjb_u:jje_u)) - ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm)) - ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm)) - ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm)) - ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ)) - ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ)) - ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ)) - ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ)) - ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ)) - ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ)) - ALLOCATE(zvQtmp(jjb_v:jje_v,llm)) - ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ)) - ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ)) - ALLOCATE(zmasse(jjb_v:jje_v,llm)) - ALLOCATE(zamasse(jjb_v:jje_v)) - ALLOCATE(zv(jjb_v:jje_v,llm)) - ALLOCATE(psi(jjb_v:jje_v,llm+1)) - ALLOCATE(ndex3d(jjb_v:jje_v*llm)) - ndex3d=0 - ALLOCATE(rlong(1)) - ALLOCATE(rlatg(jjm)) - -!$OMP END MASTER -!$OMP BARRIER - icum=0 - ! initialisation des fichiers - first=.false. - ! ncum est la frequence de stokage en pas de temps - ncum=dt_cum/dt_app - if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then - WRITE(lunout,*) & - 'Pb : le pas de cumule doit etre multiple du pas' - WRITE(lunout,*)'dt_app=',dt_app - WRITE(lunout,*)'dt_cum=',dt_cum - CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1) - endif - -!$OMP MASTER - nom(itemp)='T' - nom(igeop)='gz' - nom(iecin)='K' - nom(iang)='ang' - nom(iu)='u' - nom(iovap)='ovap' - nom(iun)='un' - - unites(itemp)='K' - unites(igeop)='m2/s2' - unites(iecin)='m2/s2' - unites(iang)='ang' - unites(iu)='m/s' - unites(iovap)='kg/kg' - unites(iun)='un' - - - ! Initialisation du fichier contenant les moyennes zonales. - ! --------------------------------------------------------- - - infile='dynzon' - - zan = annee_ref - dayref = day_ref - CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) - tau0 = itau_dyn - - rlong=0. - rlatg=rlatv*180./pi - - jjb=jj_begin - jje=jj_end - jjn=jj_nb - IF (pole_sud) THEN - jjn=jj_nb-1 - jje=jj_end-1 - ENDIF - - ddid=(/ 2 /) - dsg=(/ jjm /) - dsl=(/ jjn /) - dpf=(/ jjb /) - dpl=(/ jje /) - dhs=(/ 0 /) - dhe=(/ 0 /) - - call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & - 'box',bilan_dyn_domain_id) - - call histbeg(trim(infile), & - 1, rlong, jjn, rlatg(jjb:jje), & - 1, 1, 1, jjn, & - tau0, zjulian, dt_cum, thoriid, fileid, & - bilan_dyn_domain_id) - - ! - ! Appel a histvert pour la grille verticale - ! - call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', & - llm, presnivs, zvertiid) - ! - ! Appels a histdef pour la definition des variables a sauvegarder - do iQ=1,nQ - do itr=1,ntr - if(itr.eq.1) then - znom(itr,iQ)=nom(iQ) - znoml(itr,iQ)=nom(iQ) - zunites(itr,iQ)=unites(iQ) - else - znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) - znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) - zunites(itr,iQ)='m/s * '//unites(iQ) - endif - enddo - enddo - - ! Declarations des champs avec dimension verticale - ! print*,'1HISTDEF' - do iQ=1,nQ - do itr=1,ntr - IF (prt_level > 5) & - WRITE(lunout,*)'var ',itr,iQ & - ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) - call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), & - zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, & - 32,'ave(X)',dt_cum,dt_cum) - enddo - ! Declarations pour les fonctions de courant - ! print*,'2HISTDEF' - call histdef(fileid,'psi'//nom(iQ) & - ,'stream fn. '//znoml(itot,iQ), & - zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, & - 32,'ave(X)',dt_cum,dt_cum) - enddo - - - ! Declarations pour les champs de transport d'air - ! print*,'3HISTDEF' - call histdef(fileid, 'masse', 'masse', & - 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, & - 32, 'ave(X)', dt_cum, dt_cum) - call histdef(fileid, 'v', 'v', & - 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, & - 32, 'ave(X)', dt_cum, dt_cum) - ! Declarations pour les fonctions de courant - ! print*,'4HISTDEF' - call histdef(fileid,'psi','stream fn. MMC ','mega t/s', & - 1,jjn,thoriid,llm,1,llm,zvertiid, & - 32,'ave(X)',dt_cum,dt_cum) - - - ! Declaration des champs 1D de transport en latitude - ! print*,'5HISTDEF' - do iQ=1,nQ - do itr=2,ntr - call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), & - zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, & - 32,'ave(X)',dt_cum,dt_cum) - enddo - enddo - - - ! print*,'8HISTDEF' - CALL histend(fileid) - -!$OMP END MASTER - endif - - - !===================================================================== - ! Calcul des champs dynamiques - ! ---------------------------- - - jjb=jj_begin - jje=jj_end - - ! �nergie cin�tique - ! ucont(:,jjb:jje,:)=0 - - call Register_Hallo_u(ucov,llm,1,1,1,1,Req) - call Register_Hallo_v(vcov,llm,1,1,1,1,Req) - call SendRequest(Req) -!$OMP BARRIER - call WaitRequest(Req) - - CALL covcont_loc(llm,ucov,vcov,ucont,vcont) - CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) - - ! moment cin�tique -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) - unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) - enddo -!$OMP END DO NOWAIT - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp - Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l) - Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l) - Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l) - Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l) - Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1) - Q(:,jjb:jje,l,iun)=1. - ENDDO -!$OMP END DO NOWAIT - - !===================================================================== - ! Cumul - !===================================================================== - ! - if(icum.EQ.0) then - jjb=jj_begin - jje=jj_end - -!$OMP MASTER - ps_cum(:,jjb:jje)=0. -!$OMP END MASTER - - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - masse_cum(:,jjb:jje,l)=0. - flux_u_cum(:,jjb:jje,l)=0. - Q_cum(:,jjb:jje,l,:)=0. - flux_uQ_cum(:,jjb:jje,l,:)=0. - if (pole_sud) jje=jj_end-1 - flux_v_cum(:,jjb:jje,l)=0. - flux_vQ_cum(:,jjb:jje,l,:)=0. - ENDDO -!$OMP END DO NOWAIT - endif - - IF (prt_level > 5) & - WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 - icum=icum+1 - - ! accumulation des flux de masse horizontaux - jjb=jj_begin - jje=jj_end - -!$OMP MASTER - ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) -!$OMP END MASTER - - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l) - flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) & - +flux_u(:,jjb:jje,l) - ENDDO -!$OMP END DO NOWAIT - - if (pole_sud) jje=jj_end-1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) & - +flux_v(:,jjb:jje,l) - ENDDO -!$OMP END DO NOWAIT - - jjb=jj_begin - jje=jj_end - - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) & - +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l) - ENDDO -!$OMP END DO NOWAIT - enddo - - !===================================================================== - ! FLUX ET TENDANCES - !===================================================================== - - ! Flux longitudinal - ! ----------------- - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - do j=jjb,jje - do i=1,iim - flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) & - +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) - enddo - flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) - enddo - enddo -!$OMP END DO NOWAIT - enddo - - ! flux m�ridien - ! ------------- - do iQ=1,nQ - call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req) - enddo - call SendRequest(Req) -!$OMP BARRIER - call WaitRequest(Req) - - jjb=jj_begin - jje=jj_end - if (pole_sud) jje=jj_end-1 - - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - do j=jjb,jje - do i=1,iip1 - flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) & - +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) - enddo - enddo - enddo -!$OMP ENDDO NOWAIT -!$OMP BARRIER - enddo - - ! tendances - ! --------- - - ! convergence horizontale - call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req) - call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req) - call SendRequest(Req) -!$OMP BARRIER - call WaitRequest(Req) - - call convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) - - ! calcul de la vitesse verticale - call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req) - call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req) - call SendRequest(Req) -!$OMP BARRIER - call WaitRequest(Req) - - call convmas_loc(flux_u_cum,flux_v_cum,convm) - CALL vitvert_loc(convm,w) -!$OMP BARRIER - - - jjb=jj_begin - jje=jj_end - - ! do iQ=1,nQ - ! do l=1,llm-1 - ! do j=jjb,jje - ! do i=1,iip1 - ! ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) - ! dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww - ! dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww - ! enddo - ! enddo - ! enddo - ! enddo - - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - IF (l2) THEN - do j=jjb,jje - do i=1,iip1 - ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ)) - dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww - enddo - enddo - ENDIF - enddo -!$OMP ENDDO NOWAIT - enddo - IF (prt_level > 5) & - WRITE(lunout,*)'Apres les calculs fait a chaque pas' - !===================================================================== - ! PAS DE TEMPS D'ECRITURE - !===================================================================== - if (icum.eq.ncum) then - !===================================================================== - - IF (prt_level > 5) & - WRITE(lunout,*)'Pas d ecriture' - - jjb=jj_begin - jje=jj_end - - ! Normalisation - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) & - /masse_cum(:,jjb:jje,l) - enddo -!$OMP ENDDO NOWAIT - enddo - - zz=1./REAL(ncum) - -!$OMP MASTER - ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz -!$OMP END MASTER - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz - flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz - flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz - dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz - ENDDO -!$OMP ENDDO NOWAIT - - IF (pole_sud) jje=jj_end-1 -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz - flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz - ENDDO -!$OMP ENDDO NOWAIT -!$OMP BARRIER - - jjb=jj_begin - jje=jj_end - - - ! A retravailler eventuellement - ! division de dQ par la masse pour revenir aux bonnes grandeurs - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l) - ENDDO -!$OMP ENDDO NOWAIT - enddo - - !===================================================================== - ! Transport m�ridien - !===================================================================== - - ! cumul zonal des masses des mailles - ! ---------------------------------- - jjb=jj_begin - jje=jj_end - if (pole_sud) jje=jj_end-1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - zv(jjb:jje,l)=0. - zmasse(jjb:jje,l)=0. - ENDDO -!$OMP ENDDO NOWAIT -!$OMP BARRIER - - call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req) - do iQ=1,nQ - call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req) - enddo - - call SendRequest(Req) -!$OMP BARRIER - call WaitRequest(Req) - - call massbar_loc(masse_cum,massebx,masseby) - - jjb=jj_begin - jje=jj_end - if (pole_sud) jje=jj_end-1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - do j=jjb,jje - do i=1,iim - zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) - zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) - enddo - zfactv(j,l)=cv(1,j)/zmasse(j,l) - enddo - enddo -!$OMP ENDDO NOWAIT -!$OMP BARRIER - - ! print*,'3OK' - ! -------------------------------------------------------------- - ! calcul de la moyenne zonale du transport : - ! ------------------------------------------ - ! - ! -- - ! TOT : la circulation totale [ vq ] - ! - ! - - - ! MMC : mean meridional circulation [ v ] [ q ] - ! - ! ---- -- - - - ! TRS : transitoires [ v'q'] = [ vq ] - [ v q ] - ! - ! - * - * - - - - - ! STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] - ! - ! - - - ! on utilise aussi l'intermediaire TMP : [ v q ] - ! - ! la variable zfactv transforme un transport meridien cumule - ! en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte - ! - ! -------------------------------------------------------------- - - - ! ---------------------------------------- - ! Transport dans le plan latitude-altitude - ! ---------------------------------------- - - jjb=jj_begin - jje=jj_end - if (pole_sud) jje=jj_end-1 - - zvQ=0. - psiQ=0. - do iQ=1,nQ -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - do l=1,llm - zvQtmp(:,l)=0. - do j=jjb,jje - ! print*,'j,l,iQ=',j,l,iQ - ! Calcul des moyennes zonales du transort total et de zvQtmp - do i=1,iim - zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) & - +flux_vQ_cum(i,j,l,iQ) - zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ & - Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) - zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy & - /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) - zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy - enddo - ! print*,'aOK' - ! Decomposition - zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) - zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) - zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) - zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) - zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) - zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) - enddo - enddo -!$OMP ENDDO NOWAIT - ! fonction de courant meridienne pour la quantite Q -!$OMP BARRIER -!$OMP MASTER - do l=llm,1,-1 - do j=jjb,jje - psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) - enddo - enddo -!$OMP END MASTER -!$OMP BARRIER - enddo - - ! fonction de courant pour la circulation meridienne moyenne -!$OMP BARRIER -!$OMP MASTER - psi(jjb:jje,:)=0. - do l=llm,1,-1 - do j=jjb,jje - psi(j,l)=psi(j,l+1)+zv(j,l) - zv(j,l)=zv(j,l)*zfactv(j,l) - enddo - enddo -!$OMP END MASTER -!$OMP BARRIER - - ! print*,'4OK' - ! sorties proprement dites -!$OMP MASTER - if (i_sortie.eq.1) then - jjb=jj_begin - jje=jj_end - jjn=jj_nb - if (pole_sud) jje=jj_end-1 - if (pole_sud) jjn=jj_nb-1 - do iQ=1,nQ - do itr=1,ntr - call histwrite(fileid,znom(itr,iQ),itau, & - zvQ(jjb:jje,:,itr,iQ) & - ,jjn*llm,ndex3d) - enddo - call histwrite(fileid,'psi'//nom(iQ), & - itau,psiQ(jjb:jje,1:llm,iQ) & - ,jjn*llm,ndex3d) - enddo - - call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) & - ,jjn*llm,ndex3d) - call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) & - ,jjn*llm,ndex3d) - psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 - call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), & - jjn*llm,ndex3d) - - endif - - - ! ----------------- - ! Moyenne verticale - ! ----------------- - - zamasse(jjb:jje)=0. - do l=1,llm - zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) - enddo - - zavQ(jjb:jje,:,:)=0. - do iQ=1,nQ - do itr=2,ntr - do l=1,llm - zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) & - +zvQ(jjb:jje,l,itr,iQ) & - *zmasse(jjb:jje,l) - enddo - zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) - call histwrite(fileid,'a'//znom(itr,iQ),itau, & - zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) - enddo - enddo -!$OMP END MASTER - ! on doit pouvoir tracer systematiquement la fonction de courant. - - !===================================================================== - !///////////////////////////////////////////////////////////////////// - icum=0 !/////////////////////////////////////// - endif ! icum.eq.ncum !/////////////////////////////////////// - !///////////////////////////////////////////////////////////////////// - !===================================================================== -!$OMP MASTER - call histsync(fileid) -!$OMP END MASTER - - - return -end subroutine bilan_dyn_loc Index: LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90 (revision 5268) @@ -0,0 +1,843 @@ +! +! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, & + ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + + ! AFAIRE + ! Prevoir en champ nq+1 le diagnostique de l'energie + ! en faisant Qzon=Cv T + L * ... + ! vQ..A=Cp T + L * ... + + USE IOIPSL + USE parallel_lmdz + USE mod_hallo + use misc_mod + USE write_field_loc + USE comconst_mod, ONLY: cpp, pi + USE comvert_mod, ONLY: presnivs + USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comgeom2.h" + include "iniprint.h" + + !==================================================================== + ! + ! Sous-programme consacre � des diagnostics dynamiques de base + ! + ! + ! De facon generale, les moyennes des scalaires Q sont ponderees par + ! la masse. + ! + ! Les flux de masse sont eux simplement moyennes. + ! + !==================================================================== + + ! Arguments : + ! =========== + + integer :: ntrac + real :: dt_app,dt_cum + real :: ps(iip1,jjb_u:jje_u) + real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm) + real :: flux_u(iip1,jjb_u:jje_u,llm) + real :: flux_v(iip1,jjb_v:jje_v,llm) + real :: teta(iip1,jjb_u:jje_u,llm) + real :: phi(iip1,jjb_u:jje_u,llm) + real :: ucov(iip1,jjb_u:jje_u,llm) + real :: vcov(iip1,jjb_v:jje_v,llm) + real :: trac(iip1,jjb_u:jje_u,llm,ntrac) + + ! Local : + ! ======= + + integer,SAVE :: icum,ncum +!$OMP THREADPRIVATE(icum,ncum) + LOGICAL,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + real :: zz,zqy + REAl,SAVE,ALLOCATABLE :: zfactv(:,:) + + INTEGER,PARAMETER :: nQ=7 + + + !ym character*6 nom(nQ) + !ym character*6 unites(nQ) + character(len=6),save :: nom(nQ) + character(len=6),save :: unites(nQ) + + character(len=10) file + integer :: ifile + parameter (ifile=4) + + integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5 + INTEGER,PARAMETER :: iovap=6,iun=7 + integer,PARAMETER :: i_sortie=1 + + real,SAVE :: time=0. + integer,SAVE :: itau=0. +!$OMP THREADPRIVATE(time,itau) + + real :: ww + + ! variables dynamiques interm�diaires + REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:) + REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:) + REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:) + REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:) + REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:) + REAL,SAVE,ALLOCATABLE :: bern(:,:,:) + + ! champ contenant les scalaires advect�s. + real,SAVE,ALLOCATABLE :: Q(:,:,:,:) + + ! champs cumul�s + real,SAVE,ALLOCATABLE :: ps_cum(:,:) + real,SAVE,ALLOCATABLE :: masse_cum(:,:,:) + real,SAVE,ALLOCATABLE :: flux_u_cum(:,:,:) + real,SAVE,ALLOCATABLE :: flux_v_cum(:,:,:) + real,SAVE,ALLOCATABLE :: Q_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_uQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_vQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_wQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: dQ(:,:,:,:) + + + ! champs de tansport en moyenne zonale + integer :: ntr,itr + parameter (ntr=5) + + !ym character*10 znom(ntr,nQ) + !ym character*20 znoml(ntr,nQ) + !ym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5 + + character(len=3) :: ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real,SAVE,ALLOCATABLE :: zvQ(:,:,:,:),zvQtmp(:,:) + real,SAVE,ALLOCATABLE :: zavQ(:,:,:),psiQ(:,:,:) + real,SAVE,ALLOCATABLE :: zmasse(:,:),zamasse(:) + + real,SAVE,ALLOCATABLE :: zv(:,:),psi(:,:) + + integer :: i,j,l,iQ + + + ! Initialisation du fichier contenant les moyennes zonales. + ! --------------------------------------------------------- + + character(len=10) :: infile + + integer, save :: fileid + integer :: thoriid, zvertiid + + INTEGER,SAVE,ALLOCATABLE :: ndex3d(:) + + ! Variables locales + ! + integer :: tau0 + real :: zjulian + character(len=3) :: str + character(len=10) :: ctrac + integer :: ii,jj + integer :: zan, dayref + ! + real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:) + integer :: jjb,jje,jjn,ijb,ije + type(Request),SAVE :: Req +!$OMP THREADPRIVATE(Req) + + ! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(1) :: ddid + INTEGER,DIMENSION(1) :: dsg + INTEGER,DIMENSION(1) :: dsl + INTEGER,DIMENSION(1) :: dpf + INTEGER,DIMENSION(1) :: dpl + INTEGER,DIMENSION(1) :: dhs + INTEGER,DIMENSION(1) :: dhe + + INTEGER :: bilan_dyn_domain_id + + !===================================================================== + ! Initialisation + !===================================================================== + if (adjust) return + + time=time+dt_app + itau=itau+1 + + if (first) then +!$OMP BARRIER +!$OMP MASTER + ALLOCATE(zfactv(jjb_v:jje_v,llm)) + ALLOCATE(vcont(iip1,jjb_v:jje_v,llm)) + ALLOCATE(ucont(iip1,jjb_u:jje_u,llm)) + ALLOCATE(ang(iip1,jjb_u:jje_u,llm)) + ALLOCATE(unat(iip1,jjb_u:jje_u,llm)) + ALLOCATE(massebx(iip1,jjb_u:jje_u,llm)) + ALLOCATE(masseby(iip1,jjb_v:jje_v,llm)) + ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm)) + ALLOCATE(w(iip1,jjb_u:jje_u,llm)) + ALLOCATE(ecin(iip1,jjb_u:jje_u,llm)) + ALLOCATE(convm(iip1,jjb_u:jje_u,llm)) + ALLOCATE(bern(iip1,jjb_u:jje_u,llm)) + ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(ps_cum(iip1,jjb_u:jje_u)) + ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm)) + ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm)) + ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm)) + ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ)) + ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ)) + ALLOCATE(zvQtmp(jjb_v:jje_v,llm)) + ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ)) + ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ)) + ALLOCATE(zmasse(jjb_v:jje_v,llm)) + ALLOCATE(zamasse(jjb_v:jje_v)) + ALLOCATE(zv(jjb_v:jje_v,llm)) + ALLOCATE(psi(jjb_v:jje_v,llm+1)) + ALLOCATE(ndex3d(jjb_v:jje_v*llm)) + ndex3d=0 + ALLOCATE(rlong(1)) + ALLOCATE(rlatg(jjm)) + +!$OMP END MASTER +!$OMP BARRIER + icum=0 + ! initialisation des fichiers + first=.false. + ! ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) & + 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1) + endif + +!$OMP MASTER + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + + ! Initialisation du fichier contenant les moyennes zonales. + ! --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) THEN + jjn=jj_nb-1 + jje=jj_end-1 + ENDIF + + ddid=(/ 2 /) + dsg=(/ jjm /) + dsl=(/ jjn /) + dpf=(/ jjb /) + dpl=(/ jje /) + dhs=(/ 0 /) + dhe=(/ 0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'box',bilan_dyn_domain_id) + + call histbeg(trim(infile), & + 1, rlong, jjn, rlatg(jjb:jje), & + 1, 1, 1, jjn, & + tau0, zjulian, dt_cum, thoriid, fileid, & + bilan_dyn_domain_id) + + ! + ! Appel a histvert pour la grille verticale + ! + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', & + llm, presnivs, zvertiid) + ! + ! Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + + ! Declarations des champs avec dimension verticale + ! print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) & + WRITE(lunout,*)'var ',itr,iQ & + ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), & + zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, & + 32,'ave(X)',dt_cum,dt_cum) + enddo + ! Declarations pour les fonctions de courant + ! print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) & + ,'stream fn. '//znoml(itot,iQ), & + zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, & + 32,'ave(X)',dt_cum,dt_cum) + enddo + + + ! Declarations pour les champs de transport d'air + ! print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', & + 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, & + 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', & + 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, & + 32, 'ave(X)', dt_cum, dt_cum) + ! Declarations pour les fonctions de courant + ! print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', & + 1,jjn,thoriid,llm,1,llm,zvertiid, & + 32,'ave(X)',dt_cum,dt_cum) + + + ! Declaration des champs 1D de transport en latitude + ! print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), & + zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, & + 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + + ! print*,'8HISTDEF' + CALL histend(fileid) + +!$OMP END MASTER + endif + + + !===================================================================== + ! Calcul des champs dynamiques + ! ---------------------------- + + jjb=jj_begin + jje=jj_end + + ! �nergie cin�tique + ! ucont(:,jjb:jje,:)=0 + + call Register_Hallo_u(ucov,llm,1,1,1,1,Req) + call Register_Hallo_v(vcov,llm,1,1,1,1,Req) + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) + + ! moment cin�tique +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) + unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) + enddo +!$OMP END DO NOWAIT + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp + Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l) + Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l) + Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l) + Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l) + Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1) + Q(:,jjb:jje,l,iun)=1. + ENDDO +!$OMP END DO NOWAIT + + !===================================================================== + ! Cumul + !===================================================================== + ! + if(icum.EQ.0) then + jjb=jj_begin + jje=jj_end + +!$OMP MASTER + ps_cum(:,jjb:jje)=0. +!$OMP END MASTER + + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,l)=0. + flux_u_cum(:,jjb:jje,l)=0. + Q_cum(:,jjb:jje,l,:)=0. + flux_uQ_cum(:,jjb:jje,l,:)=0. + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,l)=0. + flux_vQ_cum(:,jjb:jje,l,:)=0. + ENDDO +!$OMP END DO NOWAIT + endif + + IF (prt_level > 5) & + WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + + ! accumulation des flux de masse horizontaux + jjb=jj_begin + jje=jj_end + +!$OMP MASTER + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) +!$OMP END MASTER + + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l) + flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) & + +flux_u(:,jjb:jje,l) + ENDDO +!$OMP END DO NOWAIT + + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) & + +flux_v(:,jjb:jje,l) + ENDDO +!$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) & + +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l) + ENDDO +!$OMP END DO NOWAIT + enddo + + !===================================================================== + ! FLUX ET TENDANCES + !===================================================================== + + ! Flux longitudinal + ! ----------------- + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) & + +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo +!$OMP END DO NOWAIT + enddo + + ! flux m�ridien + ! ------------- + do iQ=1,nQ + call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req) + enddo + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) & + +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo +!$OMP ENDDO NOWAIT +!$OMP BARRIER + enddo + + ! tendances + ! --------- + + ! convergence horizontale + call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req) + call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req) + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + + ! calcul de la vitesse verticale + call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req) + call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req) + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call convmas_loc(flux_u_cum,flux_v_cum,convm) + CALL vitvert_loc(convm,w) +!$OMP BARRIER + + + jjb=jj_begin + jje=jj_end + + ! do iQ=1,nQ + ! do l=1,llm-1 + ! do j=jjb,jje + ! do i=1,iip1 + ! ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + ! dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + ! dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + ! enddo + ! enddo + ! enddo + ! enddo + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + IF (l2) THEN + do j=jjb,jje + do i=1,iip1 + ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ)) + dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww + enddo + enddo + ENDIF + enddo +!$OMP ENDDO NOWAIT + enddo + IF (prt_level > 5) & + WRITE(lunout,*)'Apres les calculs fait a chaque pas' + !===================================================================== + ! PAS DE TEMPS D'ECRITURE + !===================================================================== + if (icum.eq.ncum) then + !===================================================================== + + IF (prt_level > 5) & + WRITE(lunout,*)'Pas d ecriture' + + jjb=jj_begin + jje=jj_end + + ! Normalisation + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) & + /masse_cum(:,jjb:jje,l) + enddo +!$OMP ENDDO NOWAIT + enddo + + zz=1./REAL(ncum) + +!$OMP MASTER + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz +!$OMP END MASTER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz + flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz + flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz + dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz + ENDDO +!$OMP ENDDO NOWAIT + + IF (pole_sud) jje=jj_end-1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz + flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz + ENDDO +!$OMP ENDDO NOWAIT +!$OMP BARRIER + + jjb=jj_begin + jje=jj_end + + + ! A retravailler eventuellement + ! division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l) + ENDDO +!$OMP ENDDO NOWAIT + enddo + + !===================================================================== + ! Transport m�ridien + !===================================================================== + + ! cumul zonal des masses des mailles + ! ---------------------------------- + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + zv(jjb:jje,l)=0. + zmasse(jjb:jje,l)=0. + ENDDO +!$OMP ENDDO NOWAIT +!$OMP BARRIER + + call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req) + do iQ=1,nQ + call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req) + enddo + + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call massbar_loc(masse_cum,massebx,masseby) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo +!$OMP ENDDO NOWAIT +!$OMP BARRIER + + ! print*,'3OK' + ! -------------------------------------------------------------- + ! calcul de la moyenne zonale du transport : + ! ------------------------------------------ + ! + ! -- + ! TOT : la circulation totale [ vq ] + ! + ! - - + ! MMC : mean meridional circulation [ v ] [ q ] + ! + ! ---- -- - - + ! TRS : transitoires [ v'q'] = [ vq ] - [ v q ] + ! + ! - * - * - - - - + ! STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] + ! + ! - - + ! on utilise aussi l'intermediaire TMP : [ v q ] + ! + ! la variable zfactv transforme un transport meridien cumule + ! en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte + ! + ! -------------------------------------------------------------- + + + ! ---------------------------------------- + ! Transport dans le plan latitude-altitude + ! ---------------------------------------- + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zvQ=0. + psiQ=0. + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + zvQtmp(:,l)=0. + do j=jjb,jje + ! print*,'j,l,iQ=',j,l,iQ + ! Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) & + +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ & + Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy & + /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo + ! print*,'aOK' + ! Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +!$OMP ENDDO NOWAIT + ! fonction de courant meridienne pour la quantite Q +!$OMP BARRIER +!$OMP MASTER + do l=llm,1,-1 + do j=jjb,jje + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo +!$OMP END MASTER +!$OMP BARRIER + enddo + + ! fonction de courant pour la circulation meridienne moyenne +!$OMP BARRIER +!$OMP MASTER + psi(jjb:jje,:)=0. + do l=llm,1,-1 + do j=jjb,jje + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo +!$OMP END MASTER +!$OMP BARRIER + + ! print*,'4OK' + ! sorties proprement dites +!$OMP MASTER + if (i_sortie.eq.1) then + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau, & + zvQ(jjb:jje,:,itr,iQ) & + ,jjn*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ), & + itau,psiQ(jjb:jje,1:llm,iQ) & + ,jjn*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) & + ,jjn*llm,ndex3d) + call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) & + ,jjn*llm,ndex3d) + psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 + call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), & + jjn*llm,ndex3d) + + endif + + + ! ----------------- + ! Moyenne verticale + ! ----------------- + + zamasse(jjb:jje)=0. + do l=1,llm + zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) + enddo + + zavQ(jjb:jje,:,:)=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) & + +zvQ(jjb:jje,l,itr,iQ) & + *zmasse(jjb:jje,l) + enddo + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) + call histwrite(fileid,'a'//znom(itr,iQ),itau, & + zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) + enddo + enddo +!$OMP END MASTER + ! on doit pouvoir tracer systematiquement la fonction de courant. + + !===================================================================== + !///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// + !///////////////////////////////////////////////////////////////////// + !===================================================================== +!$OMP MASTER + call histsync(fileid) +!$OMP END MASTER + + + return +end subroutine bilan_dyn_loc Index: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90 (revision 5267) +++ (revision ) @@ -1,217 +1,0 @@ -! -! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $ -! -! -! - SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , & - p ,masse, dq , teta, & - flxw, pk, iapptrac) - USE parallel_lmdz - USE infotrac, ONLY : nqtot - USE control_mod, ONLY : iapp_tracvl,planet_type - USE caladvtrac_mod - USE mod_hallo - USE bands - USE times - USE Vampir - USE write_field_loc - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - IMPLICIT NONE - ! - ! Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron - ! - ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur - !======================================================================= - ! - ! Shema de Van Leer - ! - !======================================================================= - - - include "dimensions.h" - include "paramet.h" - - ! Arguments: - ! ---------- - REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm) - REAL :: masse(ijb_u:ije_u,llm) - REAL :: p( ijb_u:ije_u,llmp1) - REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot ) - REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm) - REAL :: flxw(ijb_u:ije_u,llm) - INTEGER :: iapptrac - ! Local: - ! ------ - ! REAL :: pbarug(ijb_u:ije_u,llm) - ! REAL :: pbarvg(ijb_v:ije_v,llm) - ! REAL :: wg(ijb_u:ije_u,llm) - - REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm) - INTEGER,SAVE :: iadvtr=0 -!$OMP THREADPRIVATE(iadvtr) - INTEGER :: ijb,ije,ijbu,ijbv,ijeu,ijev,j - INTEGER :: ij,l - TYPE(Request),SAVE :: Request_vanleer -!$OMP THREADPRIVATE(Request_vanleer) - - ! !write(*,*) 'caladvtrac 58: entree' - ijbu=ij_begin - ijeu=ij_end - - ijbv=ij_begin-iip1 - ijev=ij_end - if (pole_nord) ijbv=ij_begin - if (pole_sud) ijev=ij_end-iip1 - - IF(iadvtr.EQ.0) THEN -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - pbaruc(ijbu:ijeu,l)=0. - pbarvc(ijbv:ijev,l)=0. - ENDDO -!$OMP END DO NOWAIT - ENDIF - - ! accumulation des flux de masse horizontaux -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij = ijbu,ijeu - pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) - ENDDO - DO ij = ijbv,ijev - pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) - ENDDO - ENDDO -!$OMP END DO NOWAIT - - ! selection de la masse instantannee des mailles avant le transport. - IF(iadvtr.EQ.0) THEN - - ijb=ij_begin - ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - massem(ijb:ije,l)=masse(ijb:ije,l) - ENDDO -!$OMP END DO NOWAIT - - ENDIF - - iadvtr = iadvtr+1 - -!$OMP MASTER - iapptrac = iadvtr -!$OMP END MASTER - - ! Test pour savoir si on advecte a ce pas de temps - - IF ( iadvtr.EQ.iapp_tracvl ) THEN - ! !write(*,*) 'caladvtrac 133' -!$OMP MASTER - call suspend_timer(timer_caldyn) -!$OMP END MASTER - - ijb=ij_begin - ije=ij_end - - !c .. Modif P.Le Van ( 20/12/97 ) .... - !c - - ! traitement des flux de masse avant advection. - ! 1. calcul de w - ! 2. groupement des mailles pres du pole. - - CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl) - ENDDO -!$OMP ENDDO NOWAIT - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('pbarug1',pbarug) - CALL WriteField_v('pbarvg1',pbarvg) - CALL WriteField_u('wg1',wg) -END IF - -!$OMP BARRIER - - -!$OMP MASTER - call VTb(VTHallo) -!$OMP END MASTER - - call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, & - Request_vanleer) - call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, & - Request_vanleer,up=1) - call Register_SwapField_u(massem,massem_adv, distrib_vanleer, & - Request_vanleer) - call Register_SwapField_u(wg,wg_adv,distrib_vanleer, & - Request_vanleer) - call Register_SwapField_u(teta,teta_adv, distrib_vanleer, & - Request_vanleer,up=1,down=1) - call Register_SwapField_u(p,p_adv, distrib_vanleer, & - Request_vanleer,up=1,down=1) - call Register_SwapField_u(pk,pk_adv, distrib_vanleer, & - Request_vanleer,up=1,down=1) - call Register_SwapField_u(q,q_adv, distrib_vanleer, & - Request_vanleer) - - call SendRequest(Request_vanleer) -!$OMP BARRIER - call WaitRequest(Request_vanleer) - - -!$OMP BARRIER -!$OMP MASTER - call Set_Distrib(distrib_vanleer) - call VTe(VTHallo) - call VTb(VTadvection) - call start_timer(timer_vanleer) -!$OMP END MASTER -!$OMP BARRIER - ! CALL WriteField_u('pbarug_adv',pbarug_adv) - ! CALL WriteField_u('',) - - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('pbarug1',pbarug_adv) - CALL WriteField_v('pbarvg1',pbarvg_adv) - CALL WriteField_u('wg1',wg_adv) -END IF - ! !write(*,*) 'caladvtrac 185' - CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, & - p_adv, massem_adv,q_adv, teta_adv, & - pk_adv) - ! !write(*,*) 'caladvtrac 189' - - -!$OMP MASTER - call VTe(VTadvection) - call stop_timer(timer_vanleer) - call VTb(VThallo) -!$OMP END MASTER - - call Register_SwapField_u(q_adv,q,distrib_caldyn, & - Request_vanleer) - - call SendRequest(Request_vanleer) -!$OMP BARRIER - call WaitRequest(Request_vanleer) - -!$OMP BARRIER -!$OMP MASTER - call Set_Distrib(distrib_caldyn) - call VTe(VThallo) - call resume_timer(timer_caldyn) -!$OMP END MASTER -!$OMP BARRIER - iadvtr=0 - ENDIF ! if iadvtr.EQ.iapp_tracvl - -END SUBROUTINE caladvtrac_loc - - Index: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90 (revision 5268) @@ -0,0 +1,217 @@ +! +! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +! +! + SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , & + p ,masse, dq , teta, & + flxw, pk, iapptrac) + USE parallel_lmdz + USE infotrac, ONLY : nqtot + USE control_mod, ONLY : iapp_tracvl,planet_type + USE caladvtrac_mod + USE mod_hallo + USE bands + USE times + USE Vampir + USE write_field_loc + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + IMPLICIT NONE + ! + ! Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron + ! + ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur + !======================================================================= + ! + ! Shema de Van Leer + ! + !======================================================================= + + + include "dimensions.h" + include "paramet.h" + + ! Arguments: + ! ---------- + REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm) + REAL :: masse(ijb_u:ije_u,llm) + REAL :: p( ijb_u:ije_u,llmp1) + REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot ) + REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm) + REAL :: flxw(ijb_u:ije_u,llm) + INTEGER :: iapptrac + ! Local: + ! ------ + ! REAL :: pbarug(ijb_u:ije_u,llm) + ! REAL :: pbarvg(ijb_v:ije_v,llm) + ! REAL :: wg(ijb_u:ije_u,llm) + + REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm) + INTEGER,SAVE :: iadvtr=0 +!$OMP THREADPRIVATE(iadvtr) + INTEGER :: ijb,ije,ijbu,ijbv,ijeu,ijev,j + INTEGER :: ij,l + TYPE(Request),SAVE :: Request_vanleer +!$OMP THREADPRIVATE(Request_vanleer) + + ! !write(*,*) 'caladvtrac 58: entree' + ijbu=ij_begin + ijeu=ij_end + + ijbv=ij_begin-iip1 + ijev=ij_end + if (pole_nord) ijbv=ij_begin + if (pole_sud) ijev=ij_end-iip1 + + IF(iadvtr.EQ.0) THEN +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pbaruc(ijbu:ijeu,l)=0. + pbarvc(ijbv:ijev,l)=0. + ENDDO +!$OMP END DO NOWAIT + ENDIF + + ! accumulation des flux de masse horizontaux +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijbu,ijeu + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = ijbv,ijev + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO +!$OMP END DO NOWAIT + + ! selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + massem(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +!$OMP END DO NOWAIT + + ENDIF + + iadvtr = iadvtr+1 + +!$OMP MASTER + iapptrac = iadvtr +!$OMP END MASTER + + ! Test pour savoir si on advecte a ce pas de temps + + IF ( iadvtr.EQ.iapp_tracvl ) THEN + ! !write(*,*) 'caladvtrac 133' +!$OMP MASTER + call suspend_timer(timer_caldyn) +!$OMP END MASTER + + ijb=ij_begin + ije=ij_end + + !c .. Modif P.Le Van ( 20/12/97 ) .... + !c + + ! traitement des flux de masse avant advection. + ! 1. calcul de w + ! 2. groupement des mailles pres du pole. + + CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl) + ENDDO +!$OMP ENDDO NOWAIT + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('pbarug1',pbarug) + CALL WriteField_v('pbarvg1',pbarvg) + CALL WriteField_u('wg1',wg) +END IF + +!$OMP BARRIER + + +!$OMP MASTER + call VTb(VTHallo) +!$OMP END MASTER + + call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, & + Request_vanleer) + call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, & + Request_vanleer,up=1) + call Register_SwapField_u(massem,massem_adv, distrib_vanleer, & + Request_vanleer) + call Register_SwapField_u(wg,wg_adv,distrib_vanleer, & + Request_vanleer) + call Register_SwapField_u(teta,teta_adv, distrib_vanleer, & + Request_vanleer,up=1,down=1) + call Register_SwapField_u(p,p_adv, distrib_vanleer, & + Request_vanleer,up=1,down=1) + call Register_SwapField_u(pk,pk_adv, distrib_vanleer, & + Request_vanleer,up=1,down=1) + call Register_SwapField_u(q,q_adv, distrib_vanleer, & + Request_vanleer) + + call SendRequest(Request_vanleer) +!$OMP BARRIER + call WaitRequest(Request_vanleer) + + +!$OMP BARRIER +!$OMP MASTER + call Set_Distrib(distrib_vanleer) + call VTe(VTHallo) + call VTb(VTadvection) + call start_timer(timer_vanleer) +!$OMP END MASTER +!$OMP BARRIER + ! CALL WriteField_u('pbarug_adv',pbarug_adv) + ! CALL WriteField_u('',) + + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('pbarug1',pbarug_adv) + CALL WriteField_v('pbarvg1',pbarvg_adv) + CALL WriteField_u('wg1',wg_adv) +END IF + ! !write(*,*) 'caladvtrac 185' + CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, & + p_adv, massem_adv,q_adv, teta_adv, & + pk_adv) + ! !write(*,*) 'caladvtrac 189' + + +!$OMP MASTER + call VTe(VTadvection) + call stop_timer(timer_vanleer) + call VTb(VThallo) +!$OMP END MASTER + + call Register_SwapField_u(q_adv,q,distrib_caldyn, & + Request_vanleer) + + call SendRequest(Request_vanleer) +!$OMP BARRIER + call WaitRequest(Request_vanleer) + +!$OMP BARRIER +!$OMP MASTER + call Set_Distrib(distrib_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) +!$OMP END MASTER +!$OMP BARRIER + iadvtr=0 + ENDIF ! if iadvtr.EQ.iapp_tracvl + +END SUBROUTINE caladvtrac_loc + + Index: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.F90 (revision 5267) +++ (revision ) @@ -1,115 +1,0 @@ -MODULE caladvtrac_mod - - REAL,POINTER,SAVE :: q_adv(:,:,:) - REAL,POINTER,SAVE :: massem_adv(:,:) - REAL,POINTER,SAVE :: wg_adv(:,:) - REAL,POINTER,SAVE :: teta_adv(:,:) - REAL,POINTER,SAVE :: p_adv(:,:) - REAL,POINTER,SAVE :: pk_adv(:,:) - REAL,POINTER,SAVE :: pbarug_adv(:,:) - REAL,POINTER,SAVE :: pbarvg_adv(:,:) - REAL,POINTER,SAVE :: pbaruc(:,:) - REAL,POINTER,SAVE :: pbarvc(:,:) - REAL,POINTER,SAVE :: pbarug(:,:) - REAL,POINTER,SAVE :: pbarvg(:,:) - REAL,POINTER,SAVE :: wg(:,:) - - REAL,POINTER,SAVE :: massem(:,:) - !Offline - REAL,POINTER,SAVE :: tetac(:,:) - REAL,POINTER,SAVE :: massec(:,:) - REAL,POINTER,SAVE :: phic(:,:) - REAL,POINTER,SAVE :: pbarucc(:,:) - REAL,POINTER,SAVE :: pbarvcc(:,:) - REAL,POINTER,SAVE :: pbarugg(:,:) - REAL,POINTER,SAVE :: pbarvgg(:,:) - REAL,POINTER,SAVE :: wgg(:,:) -CONTAINS - - SUBROUTINE caladvtrac_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE infotrac, ONLY: nqtot - USE advtrac_mod, ONLY : advtrac_allocate - USE groupe_mod - IMPLICIT NONE - INCLUDE "dimensions.h" - INCLUDE "paramet.h" - TYPE(distrib),POINTER :: d - - d=>distrib_vanleer - CALL allocate_u(q_adv,llm,nqtot,d) - CALL allocate_u(massem_adv,llm,d) - CALL allocate_u(wg_adv,llm,d) - CALL allocate_u(teta_adv,llm,d) - CALL allocate_u(p_adv,llmp1,d) - CALL allocate_u(pk_adv,llm,d) - CALL allocate_u(pbarug_adv,llm,d) - CALL allocate_v(pbarvg_adv,llm,d) - - d=>distrib_caldyn - CALL allocate_u(massem,llm,d) - CALL allocate_u(pbaruc,llm,d) - pbaruc(:,:)=0 - CALL allocate_v(pbarvc,llm,d) - pbarvc(:,:)=0 - CALL allocate_u(pbarug,llm,d) - CALL allocate_v(pbarvg,llm,d) - CALL allocate_u(wg,llm,d) - ! Offline - CALL allocate_u(tetac,llm,d) - CALL allocate_u(phic,llm,d) - CALL allocate_u(pbarucc,llm,d) - CALL allocate_v(pbarvcc,llm,d) - CALL allocate_u(massec,llm,d) - CALL allocate_u(pbarugg,llm,d) - CALL allocate_v(pbarvgg,llm,d) - CALL allocate_u(wgg,llm,d) - - CALL groupe_allocate - CALL advtrac_allocate - - END SUBROUTINE caladvtrac_allocate - - SUBROUTINE caladvtrac_switch_caldyn(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE groupe_mod - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_u(massem,distrib_caldyn,dist) - CALL switch_u(pbaruc,distrib_caldyn,dist) - CALL switch_v(pbarvc,distrib_caldyn,dist,up=1) - CALL switch_u(pbarug,distrib_caldyn,dist) - CALL switch_v(pbarvg,distrib_caldyn,dist) - CALL switch_u(wg,distrib_caldyn,dist) - - CALL groupe_switch_caldyn(dist) - - END SUBROUTINE caladvtrac_switch_caldyn - - SUBROUTINE caladvtrac_switch_vanleer(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE advtrac_mod, ONLY : advtrac_switch_vanleer - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_u(q_adv,distrib_vanleer,dist) - CALL switch_u(massem_adv,distrib_vanleer,dist) - CALL switch_u(wg_adv,distrib_vanleer,dist) - CALL switch_u(teta_adv,distrib_vanleer,dist) - CALL switch_u(p_adv,distrib_vanleer,dist) - CALL switch_u(pk_adv,distrib_vanleer,dist) - CALL switch_u(pbarug_adv,distrib_vanleer,dist) - CALL switch_v(pbarvg_adv,distrib_vanleer,dist) - - CALL advtrac_switch_vanleer(dist) - - END SUBROUTINE caladvtrac_switch_vanleer - -END MODULE caladvtrac_mod Index: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90 (revision 5268) @@ -0,0 +1,115 @@ +MODULE caladvtrac_mod + + REAL,POINTER,SAVE :: q_adv(:,:,:) + REAL,POINTER,SAVE :: massem_adv(:,:) + REAL,POINTER,SAVE :: wg_adv(:,:) + REAL,POINTER,SAVE :: teta_adv(:,:) + REAL,POINTER,SAVE :: p_adv(:,:) + REAL,POINTER,SAVE :: pk_adv(:,:) + REAL,POINTER,SAVE :: pbarug_adv(:,:) + REAL,POINTER,SAVE :: pbarvg_adv(:,:) + REAL,POINTER,SAVE :: pbaruc(:,:) + REAL,POINTER,SAVE :: pbarvc(:,:) + REAL,POINTER,SAVE :: pbarug(:,:) + REAL,POINTER,SAVE :: pbarvg(:,:) + REAL,POINTER,SAVE :: wg(:,:) + + REAL,POINTER,SAVE :: massem(:,:) + !Offline + REAL,POINTER,SAVE :: tetac(:,:) + REAL,POINTER,SAVE :: massec(:,:) + REAL,POINTER,SAVE :: phic(:,:) + REAL,POINTER,SAVE :: pbarucc(:,:) + REAL,POINTER,SAVE :: pbarvcc(:,:) + REAL,POINTER,SAVE :: pbarugg(:,:) + REAL,POINTER,SAVE :: pbarvgg(:,:) + REAL,POINTER,SAVE :: wgg(:,:) +CONTAINS + + SUBROUTINE caladvtrac_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE infotrac, ONLY: nqtot + USE advtrac_mod, ONLY : advtrac_allocate + USE groupe_mod + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(q_adv,llm,nqtot,d) + CALL allocate_u(massem_adv,llm,d) + CALL allocate_u(wg_adv,llm,d) + CALL allocate_u(teta_adv,llm,d) + CALL allocate_u(p_adv,llmp1,d) + CALL allocate_u(pk_adv,llm,d) + CALL allocate_u(pbarug_adv,llm,d) + CALL allocate_v(pbarvg_adv,llm,d) + + d=>distrib_caldyn + CALL allocate_u(massem,llm,d) + CALL allocate_u(pbaruc,llm,d) + pbaruc(:,:)=0 + CALL allocate_v(pbarvc,llm,d) + pbarvc(:,:)=0 + CALL allocate_u(pbarug,llm,d) + CALL allocate_v(pbarvg,llm,d) + CALL allocate_u(wg,llm,d) + ! Offline + CALL allocate_u(tetac,llm,d) + CALL allocate_u(phic,llm,d) + CALL allocate_u(pbarucc,llm,d) + CALL allocate_v(pbarvcc,llm,d) + CALL allocate_u(massec,llm,d) + CALL allocate_u(pbarugg,llm,d) + CALL allocate_v(pbarvgg,llm,d) + CALL allocate_u(wgg,llm,d) + + CALL groupe_allocate + CALL advtrac_allocate + + END SUBROUTINE caladvtrac_allocate + + SUBROUTINE caladvtrac_switch_caldyn(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE groupe_mod + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(massem,distrib_caldyn,dist) + CALL switch_u(pbaruc,distrib_caldyn,dist) + CALL switch_v(pbarvc,distrib_caldyn,dist,up=1) + CALL switch_u(pbarug,distrib_caldyn,dist) + CALL switch_v(pbarvg,distrib_caldyn,dist) + CALL switch_u(wg,distrib_caldyn,dist) + + CALL groupe_switch_caldyn(dist) + + END SUBROUTINE caladvtrac_switch_caldyn + + SUBROUTINE caladvtrac_switch_vanleer(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE advtrac_mod, ONLY : advtrac_switch_vanleer + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(q_adv,distrib_vanleer,dist) + CALL switch_u(massem_adv,distrib_vanleer,dist) + CALL switch_u(wg_adv,distrib_vanleer,dist) + CALL switch_u(teta_adv,distrib_vanleer,dist) + CALL switch_u(p_adv,distrib_vanleer,dist) + CALL switch_u(pk_adv,distrib_vanleer,dist) + CALL switch_u(pbarug_adv,distrib_vanleer,dist) + CALL switch_v(pbarvg_adv,distrib_vanleer,dist) + + CALL advtrac_switch_vanleer(dist) + + END SUBROUTINE caladvtrac_switch_vanleer + +END MODULE caladvtrac_mod Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90 (revision 5267) +++ (revision ) @@ -1,179 +1,0 @@ -SUBROUTINE caldyn_loc & - (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , & - phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) - USE parallel_lmdz - USE Write_Field_loc - USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, & - vorpot, ecin, bern, massebxy, convm - USE comvert_mod, ONLY: ap, bp - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - IMPLICIT NONE - - !======================================================================= - ! - ! Auteur : P. Le Van - ! - ! Objet: - ! ------ - ! - ! Calcul des tendances dynamiques. - ! - ! Modif 04/93 F.Forget - !======================================================================= - - !----------------------------------------------------------------------- - ! 0. Declarations: - ! ---------------- - - include "dimensions.h" - include "paramet.h" - include "comgeom.h" - - ! Arguments: - ! ---------- - - LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used - INTEGER,INTENT(IN) :: itau ! time step index ! not used - REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind - REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind - REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature - REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure - REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface - REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer - REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner - REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential - REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass - REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov - REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov - REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta - REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps - REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity - REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction - REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction - REAL,INTENT(IN) :: time ! current time - - ! Local: - ! ------ - - INTEGER :: ij,l,ijb,ije,ierr - - - !----------------------------------------------------------------------- - ! Compute dynamical tendencies: - !-------------------------------- - - ! ! compute contravariant winds ucont() and vcont - CALL covcont_loc ( llm , ucov , vcov , ucont, vcont ) - ! ! compute pressure p() - CALL pression_loc ( ip1jmp1, ap , bp , ps , p ) - !ym CALL psextbar ( ps , psexbarxy ) -!$OMP BARRIER - ! ! compute mass in each atmospheric mesh: masse() - CALL massdair_loc ( p , masse ) - ! ! compute X and Y-averages of mass, massebx() and masseby() - CALL massbar_loc ( masse, massebx , masseby ) - ! ! compute XY-average of mass, massebxy() - call massbarxy_loc( masse, massebxy ) - ! ! compute mass fluxes pbaru() and pbarv() - CALL flumass_loc ( massebx, masseby,vcont,ucont,pbaru,pbarv ) - ! ! compute dteta() , horizontal converging flux of theta - CALL dteta1_loc ( teta , pbaru , pbarv, dteta ) - ! ! compute convm(), horizontal converging flux of mass - CALL convmas1_loc ( pbaru, pbarv , convm ) -!$OMP BARRIER - CALL convmas2_loc ( convm ) -!$OMP BARRIER -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('ucont',ucont) - call WriteField_v('vcont',vcont) - call WriteField_u('p',p) - call WriteField_u('masse',masse) - call WriteField_u('massebx',massebx) - call WriteField_v('masseby',masseby) - call WriteField_v('massebxy',massebxy) - call WriteField_u('pbaru',pbaru) - call WriteField_v('pbarv',pbarv) - call WriteField_u('dteta',dteta) - call WriteField_u('convm',convm) -END IF - -!$OMP BARRIER -!$OMP MASTER - ijb=ij_begin - ije=ij_end - ! ! compute pressure variation due to mass convergence - DO ij =ijb, ije - dp( ij ) = convm( ij,1 ) / airesurg( ij ) - ENDDO -!$OMP END MASTER -!$OMP BARRIER - - ! ! compute vertical velocity w() - CALL vitvert_loc ( convm , w ) - ! ! compute potential vorticity vorpot() - CALL tourpot_loc ( vcov , ucov , massebxy , vorpot ) - ! ! compute rotation induced du() and dv() - CALL dudv1_loc ( vorpot , pbaru , pbarv , du , dv ) - -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('w',w) - call WriteField_v('vorpot',vorpot) - call WriteField_u('du',du) - call WriteField_v('dv',dv) -END IF - - ! ! compute kinetic energy ecin() - CALL enercin_loc ( vcov , ucov , vcont , ucont , ecin ) - ! ! compute Bernouilli function bern() - CALL bernoui_loc ( ip1jmp1, llm , phi , ecin , bern) - ! ! compute and add du() and dv() contributions from Bernouilli and pressure - CALL dudv2_loc ( teta , pkf , bern , du , dv ) - -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('ecin',ecin) - call WriteField_u('bern',bern) - call WriteField_u('du',du) - call WriteField_v('dv',dv) - call WriteField_u('pkf',pkf) -END IF - - ijb=ij_begin-iip1 - ije=ij_end+iip1 - - if (pole_nord) ijb=ij_begin - if (pole_sud) ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije - ang(ij,l) = ucov(ij,l) + constang(ij) - ENDDO - ENDDO -!$OMP END DO - - ! ! compute vertical advection contributions to du(), dv() and dteta() - CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) - - ! WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi - ! probablement. Observe sur le code compile avec pgf90 3.0-1 - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llm - DO ij = ijb, ije, iip1 - IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN - ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', - ! , ' dans caldyn' - ! PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) - dv(ij+iim,l) = dv(ij,l) - endif - enddo - enddo -!$OMP END DO NOWAIT - - ! Ehouarn: NB: output of control variables not implemented... - - RETURN -END SUBROUTINE caldyn_loc Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90 (revision 5268) @@ -0,0 +1,179 @@ +SUBROUTINE caldyn_loc & + (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , & + phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + USE parallel_lmdz + USE Write_Field_loc + USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, & + vorpot, ecin, bern, massebxy, convm + USE comvert_mod, ONLY: ap, bp + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + IMPLICIT NONE + + !======================================================================= + ! + ! Auteur : P. Le Van + ! + ! Objet: + ! ------ + ! + ! Calcul des tendances dynamiques. + ! + ! Modif 04/93 F.Forget + !======================================================================= + + !----------------------------------------------------------------------- + ! 0. Declarations: + ! ---------------- + + include "dimensions.h" + include "paramet.h" + include "comgeom.h" + + ! Arguments: + ! ---------- + + LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used + INTEGER,INTENT(IN) :: itau ! time step index ! not used + REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind + REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind + REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature + REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure + REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface + REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer + REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner + REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential + REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass + REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov + REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov + REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta + REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps + REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity + REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction + REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction + REAL,INTENT(IN) :: time ! current time + + ! Local: + ! ------ + + INTEGER :: ij,l,ijb,ije,ierr + + + !----------------------------------------------------------------------- + ! Compute dynamical tendencies: + !-------------------------------- + + ! ! compute contravariant winds ucont() and vcont + CALL covcont_loc ( llm , ucov , vcov , ucont, vcont ) + ! ! compute pressure p() + CALL pression_loc ( ip1jmp1, ap , bp , ps , p ) + !ym CALL psextbar ( ps , psexbarxy ) +!$OMP BARRIER + ! ! compute mass in each atmospheric mesh: masse() + CALL massdair_loc ( p , masse ) + ! ! compute X and Y-averages of mass, massebx() and masseby() + CALL massbar_loc ( masse, massebx , masseby ) + ! ! compute XY-average of mass, massebxy() + call massbarxy_loc( masse, massebxy ) + ! ! compute mass fluxes pbaru() and pbarv() + CALL flumass_loc ( massebx, masseby,vcont,ucont,pbaru,pbarv ) + ! ! compute dteta() , horizontal converging flux of theta + CALL dteta1_loc ( teta , pbaru , pbarv, dteta ) + ! ! compute convm(), horizontal converging flux of mass + CALL convmas1_loc ( pbaru, pbarv , convm ) +!$OMP BARRIER + CALL convmas2_loc ( convm ) +!$OMP BARRIER +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('ucont',ucont) + call WriteField_v('vcont',vcont) + call WriteField_u('p',p) + call WriteField_u('masse',masse) + call WriteField_u('massebx',massebx) + call WriteField_v('masseby',masseby) + call WriteField_v('massebxy',massebxy) + call WriteField_u('pbaru',pbaru) + call WriteField_v('pbarv',pbarv) + call WriteField_u('dteta',dteta) + call WriteField_u('convm',convm) +END IF + +!$OMP BARRIER +!$OMP MASTER + ijb=ij_begin + ije=ij_end + ! ! compute pressure variation due to mass convergence + DO ij =ijb, ije + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO +!$OMP END MASTER +!$OMP BARRIER + + ! ! compute vertical velocity w() + CALL vitvert_loc ( convm , w ) + ! ! compute potential vorticity vorpot() + CALL tourpot_loc ( vcov , ucov , massebxy , vorpot ) + ! ! compute rotation induced du() and dv() + CALL dudv1_loc ( vorpot , pbaru , pbarv , du , dv ) + +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('w',w) + call WriteField_v('vorpot',vorpot) + call WriteField_u('du',du) + call WriteField_v('dv',dv) +END IF + + ! ! compute kinetic energy ecin() + CALL enercin_loc ( vcov , ucov , vcont , ucont , ecin ) + ! ! compute Bernouilli function bern() + CALL bernoui_loc ( ip1jmp1, llm , phi , ecin , bern) + ! ! compute and add du() and dv() contributions from Bernouilli and pressure + CALL dudv2_loc ( teta , pkf , bern , du , dv ) + +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('ecin',ecin) + call WriteField_u('bern',bern) + call WriteField_u('du',du) + call WriteField_v('dv',dv) + call WriteField_u('pkf',pkf) +END IF + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO +!$OMP END DO + + ! ! compute vertical advection contributions to du(), dv() and dteta() + CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) + + ! WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi + ! probablement. Observe sur le code compile avec pgf90 3.0-1 + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN + ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', + ! , ' dans caldyn' + ! PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +!$OMP END DO NOWAIT + + ! Ehouarn: NB: output of control variables not implemented... + + RETURN +END SUBROUTINE caldyn_loc Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.F90 (revision 5267) +++ (revision ) @@ -1,75 +1,0 @@ -MODULE caldyn_mod - - REAL,POINTER,SAVE :: vcont(:,:) - REAL,POINTER,SAVE :: ucont(:,:) - REAL,POINTER,SAVE :: ang(:,:) - REAL,POINTER,SAVE :: p(:,:) - REAL,POINTER,SAVE :: massebx(:,:) - REAL,POINTER,SAVE :: masseby(:,:) - REAL,POINTER,SAVE :: psexbarxy(:,:) - REAL,POINTER,SAVE :: vorpot(:,:) - REAL,POINTER,SAVE :: ecin(:,:) - REAL,POINTER,SAVE :: bern(:,:) - REAL,POINTER,SAVE :: massebxy(:,:) - REAL,POINTER,SAVE :: convm(:,:) - - - -CONTAINS - - SUBROUTINE caldyn_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - USE advect_new_mod,ONLY : advect_new_allocate - IMPLICIT NONE - TYPE(distrib),POINTER :: d - - - d=>distrib_caldyn - CALL allocate_v(vcont,llm,d) - CALL allocate_u(ucont,llm,d) - CALL allocate_u(ang,llm,d) - CALL allocate_u(p,llmp1,d) - CALL allocate_u(massebx,llm,d) - CALL allocate_v(masseby,llm,d) - CALL allocate_v(psexbarxy,llm,d) - CALL allocate_v(vorpot,llm,d) - CALL allocate_u(ecin,llm,d) - CALL allocate_u(bern,llm,d) - CALL allocate_v(massebxy,llm,d) - CALL allocate_u(convm,llm,d) - - CALL advect_new_allocate - - END SUBROUTINE caldyn_allocate - - SUBROUTINE caldyn_switch_caldyn(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE advect_new_mod,ONLY : advect_new_switch_caldyn - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_v(vcont,distrib_caldyn,dist) - CALL switch_u(ucont,distrib_caldyn,dist) - CALL switch_u(ang,distrib_caldyn,dist) - CALL switch_u(p,distrib_caldyn,dist) - CALL switch_u(massebx,distrib_caldyn,dist) - CALL switch_v(masseby,distrib_caldyn,dist) - CALL switch_v(psexbarxy,distrib_caldyn,dist) - CALL switch_v(vorpot,distrib_caldyn,dist) - CALL switch_u(ecin,distrib_caldyn,dist) - CALL switch_u(bern,distrib_caldyn,dist) - CALL switch_v(massebxy,distrib_caldyn,dist) - CALL switch_u(convm,distrib_caldyn,dist) - - CALL advect_new_switch_caldyn(dist) - - END SUBROUTINE caldyn_switch_caldyn - - - -END MODULE caldyn_mod Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90 (revision 5268) @@ -0,0 +1,75 @@ +MODULE caldyn_mod + + REAL,POINTER,SAVE :: vcont(:,:) + REAL,POINTER,SAVE :: ucont(:,:) + REAL,POINTER,SAVE :: ang(:,:) + REAL,POINTER,SAVE :: p(:,:) + REAL,POINTER,SAVE :: massebx(:,:) + REAL,POINTER,SAVE :: masseby(:,:) + REAL,POINTER,SAVE :: psexbarxy(:,:) + REAL,POINTER,SAVE :: vorpot(:,:) + REAL,POINTER,SAVE :: ecin(:,:) + REAL,POINTER,SAVE :: bern(:,:) + REAL,POINTER,SAVE :: massebxy(:,:) + REAL,POINTER,SAVE :: convm(:,:) + + + +CONTAINS + + SUBROUTINE caldyn_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + USE advect_new_mod,ONLY : advect_new_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_v(vcont,llm,d) + CALL allocate_u(ucont,llm,d) + CALL allocate_u(ang,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(massebx,llm,d) + CALL allocate_v(masseby,llm,d) + CALL allocate_v(psexbarxy,llm,d) + CALL allocate_v(vorpot,llm,d) + CALL allocate_u(ecin,llm,d) + CALL allocate_u(bern,llm,d) + CALL allocate_v(massebxy,llm,d) + CALL allocate_u(convm,llm,d) + + CALL advect_new_allocate + + END SUBROUTINE caldyn_allocate + + SUBROUTINE caldyn_switch_caldyn(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE advect_new_mod,ONLY : advect_new_switch_caldyn + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_v(vcont,distrib_caldyn,dist) + CALL switch_u(ucont,distrib_caldyn,dist) + CALL switch_u(ang,distrib_caldyn,dist) + CALL switch_u(p,distrib_caldyn,dist) + CALL switch_u(massebx,distrib_caldyn,dist) + CALL switch_v(masseby,distrib_caldyn,dist) + CALL switch_v(psexbarxy,distrib_caldyn,dist) + CALL switch_v(vorpot,distrib_caldyn,dist) + CALL switch_u(ecin,distrib_caldyn,dist) + CALL switch_u(bern,distrib_caldyn,dist) + CALL switch_v(massebxy,distrib_caldyn,dist) + CALL switch_u(convm,distrib_caldyn,dist) + + CALL advect_new_switch_caldyn(dist) + + END SUBROUTINE caldyn_switch_caldyn + + + +END MODULE caldyn_mod Index: LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.F90 (revision 5267) +++ (revision ) @@ -1,418 +1,0 @@ -!#define DEBUG_IO -MODULE call_calfis_mod - - REAL,POINTER,SAVE :: ucov(:,:) - REAL,POINTER,SAVE :: vcov(:,:) - REAL,POINTER,SAVE :: teta(:,:) - REAL,POINTER,SAVE :: masse(:,:) - REAL,POINTER,SAVE :: ps(:) - REAL,POINTER,SAVE :: phis(:) - REAL,POINTER,SAVE :: q(:,:,:) - REAL,POINTER,SAVE :: flxw(:,:) - - REAL,POINTER,SAVE :: p(:,:) - REAL,POINTER,SAVE :: pks(:) - REAL,POINTER,SAVE :: pk(:,:) - REAL,POINTER,SAVE :: pkf(:,:) - REAL,POINTER,SAVE :: phi(:,:) - REAL,POINTER,SAVE :: du(:,:) - REAL,POINTER,SAVE :: dv(:,:) - REAL,POINTER,SAVE :: dteta(:,:) - REAL,POINTER,SAVE :: dq(:,:,:) - REAL,POINTER,SAVE :: dufi(:,:) - REAL,POINTER,SAVE :: dvfi(:,:) - REAL,POINTER,SAVE :: dtetafi(:,:) - REAL,POINTER,SAVE :: dqfi(:,:,:) - REAL,POINTER,SAVE :: dpfi(:) - - - - - -CONTAINS - - SUBROUTINE call_calfis_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - USE infotrac, ONLY: nqtot - IMPLICIT NONE - TYPE(distrib),POINTER :: d - d=>distrib_physic - - CALL allocate_u(ucov,llm,d) - CALL allocate_v(vcov,llm,d) - CALL allocate_u(teta,llm,d) - CALL allocate_u(masse,llm,d) - CALL allocate_u(ps,d) - CALL allocate_u(phis,d) - CALL allocate_u(q,llm,nqtot,d) - CALL allocate_u(flxw,llm,d) - CALL allocate_u(p,llmp1,d) - CALL allocate_u(pks,d) - pks(:)=0 - CALL allocate_u(pk,llm,d) - pk(:,:)=0 - CALL allocate_u(pkf,llm,d) - CALL allocate_u(phi,llm,d) - CALL allocate_u(du,llm,d) - CALL allocate_v(dv,llm,d) - CALL allocate_u(dteta,llm,d) - CALL allocate_u(dq,llm,nqtot,d) - CALL allocate_u(dufi,llm,d) - CALL allocate_v(dvfi,llm,d) - CALL allocate_u(dtetafi,llm,d) - CALL allocate_u(dqfi,llm,nqtot,d) - CALL allocate_u(dpfi,d) - - END SUBROUTINE call_calfis_allocate - - - SUBROUTINE call_calfis(itau,lafin,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, & - phis_dyn,q_dyn,flxw_dyn) - USE dimensions_mod - use exner_hyb_loc_m, only: exner_hyb_loc - use exner_milieu_loc_m, only: exner_milieu_loc - USE parallel_lmdz - USE times - USE mod_hallo - USE Bands - USE vampir - USE infotrac, ONLY: nqtot - USE control_mod - USE write_field_loc - USE write_field - USE comconst_mod, ONLY: dtphys - USE logic_mod, ONLY: leapf, forward, ok_strato - USE comvert_mod, ONLY: ap, bp, pressure_exner - USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS, CPPKEY_DEBUGIO - USE strings_mod, ONLY: int2str - - IMPLICIT NONE - INCLUDE "iniprint.h" - - INTEGER,INTENT(IN) :: itau ! (time) iteration step number - LOGICAL,INTENT(IN) :: lafin ! .true. if final time step - REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind - REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind - REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature - REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass - REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure - REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential - REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers - REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux - - REAL :: dufi_tmp(iip1,llm) - REAL :: dvfi_tmp(iip1,llm) - REAL :: dtetafi_tmp(iip1,llm) - REAL :: dpfi_tmp(iip1) - REAL :: dqfi_tmp(iip1,llm,nqtot) - - REAL :: jD_cur, jH_cur - CHARACTER(LEN=15) :: ztit - TYPE(Request),SAVE :: Request_physic -!$OMP THREADPRIVATE(Request_physic ) - INTEGER :: ijb,ije,l,iq - - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('pfi',p) - CALL WriteField_u('pkfi',pk) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) - ENDDO -END IF - -! -! ....... Ajout P.Le Van ( 17/04/96 ) ........... -! - - - !$OMP MASTER - CALL suspend_timer(timer_caldyn) - IF (prt_level >= 10) THEN - WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau - ENDIF - !$OMP END MASTER - - jD_cur = jD_ref + day_ini - day_ref & - & + (itau+1)/day_step - - IF (planet_type .eq."generic") THEN - ! AS: we make jD_cur to be pday - jD_cur = int(day_ini + itau/day_step) - ENDIF - - jH_cur = jH_ref + start_time + & - & mod(itau+1,day_step)/float(day_step) - if (jH_cur > 1.0 ) then - jD_cur = jD_cur +1. - jH_cur = jH_cur -1. - endif - -! Inbterface avec les routines de phylmd (phymars ... ) -! ----------------------------------------------------- - -!+jld - -! Diagnostique de conservation de l'energie : initialisation - -!-jld - !$OMP BARRIER - !$OMP MASTER - CALL VTb(VThallo) - !$OMP END MASTER - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('pfi',p) - CALL WriteField_u('pkfi',pk) -END IF - - CALL SetTag(Request_physic,800) - CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2) - CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2) - CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2) - - CALL SendRequest(Request_Physic) - !$OMP BARRIER - CALL WaitRequest(Request_Physic) - - !$OMP BARRIER - !$OMP MASTER - CALL Set_Distrib(distrib_Physic) - CALL VTe(VThallo) - - CALL VTb(VTphysiq) - !$OMP END MASTER - !$OMP BARRIER - - CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) - - !$OMP BARRIER - CALL exner_hyb_loc( ip1jmp1, ps, p, pks, pk, pkf ) - !$OMP BARRIER - CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi ) - - - CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic) - CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic) - CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic) - - CALL SendRequest(Request_Physic) - !$OMP BARRIER - CALL WaitRequest(Request_Physic) - - !$OMP BARRIER - - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('pfi',p) - CALL WriteField_u('pkfi',pk) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) - ENDDO -END IF - - !$OMP BARRIER - -IF (CPPKEY_PHYS) THEN - CALL calfis_loc(lafin ,jD_cur, jH_cur, & - ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , & - du,dv,dteta,dq, & - flxw, dufi,dvfi,dtetafi,dqfi,dpfi ) -END IF - ijb=ij_begin - ije=ij_end - IF ( .not. pole_nord) THEN - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) - dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) - dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) - dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) - ENDDO - !$OMP END DO NOWAIT - - !$OMP MASTER - dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) - !$OMP END MASTER - - ENDIF ! of if ( .not. pole_nord) - - !$OMP BARRIER - !$OMP MASTER - CALL Set_Distrib(distrib_Physic_bis) - CALL VTb(VThallo) - !$OMP END MASTER - !$OMP BARRIER - - CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic) - CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic) - CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic) - CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic) - - DO iq=1,nqtot - CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic) - ENDDO - - CALL SendRequest(Request_Physic) - !$OMP BARRIER - CALL WaitRequest(Request_Physic) - - !$OMP BARRIER - !$OMP MASTER - CALL VTe(VThallo) - CALL Set_Distrib(distrib_Physic) - !$OMP END MASTER - !$OMP BARRIER - ijb=ij_begin - IF (.not. pole_nord) THEN - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) - dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) - dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l) - dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:) - ENDDO - !$OMP END DO NOWAIT - - !$OMP MASTER - dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) - !$OMP END MASTER - - endif ! of if (.not. pole_nord) - - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('dufi',dufi) - CALL WriteField_v('dvfi',dvfi) - CALL WriteField_u('dtetafi',dtetafi) - CALL WriteField_u('dpfi',dpfi) - DO iq=1,nqtot - CALL WriteField_u('dqfi'//trim(int2str(iq)),dqfi(:,:,iq)) - ENDDO -END IF - - !$OMP BARRIER - -! ajout des tendances physiques: -! ------------------------------ -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('psfi',ps) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) - ENDDO -END IF - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('psfi',ps) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) - ENDDO -END IF - - CALL addfi_loc( dtphys, leapf, forward , & - ucov, vcov, teta , q ,ps , & - dufi, dvfi, dtetafi , dqfi ,dpfi ) - ! since addfi updates ps(), also update p(), masse() and pk() - CALL pression_loc(ip1jmp1,ap,bp,ps,p) -!$OMP BARRIER - CALL massdair_loc(p,masse) -!$OMP BARRIER - if (pressure_exner) then - CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf) - else - CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf) - endif -!$OMP BARRIER - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov) - CALL WriteField_v('vcovfi',vcov) - CALL WriteField_u('tetafi',teta) - CALL WriteField_u('psfi',ps) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) - ENDDO -END IF - - IF (ok_strato) THEN -! CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) - CALL top_bound_loc(vcov,ucov,teta,masse,dtphys) - ENDIF - - !$OMP BARRIER - !$OMP MASTER - CALL VTe(VTphysiq) - CALL VTb(VThallo) - !$OMP END MASTER - - CALL SetTag(Request_physic,800) - CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic) - CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic) - CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic) - CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic) - CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic) - CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic) - CALL SendRequest(Request_Physic) - !$OMP BARRIER - CALL WaitRequest(Request_Physic) - - !$OMP BARRIER - !$OMP MASTER - CALL VTe(VThallo) - CALL set_distrib(distrib_caldyn) - !$OMP END MASTER - !$OMP BARRIER - -! -! Diagnostique de conservation de l'energie : difference - IF (ip_ebil_dyn.ge.1 ) THEN - ztit='bil phys' -! CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) - write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!" - ENDIF - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('ucovfi',ucov_dyn) - CALL WriteField_v('vcovfi',vcov_dyn) - CALL WriteField_u('tetafi',teta_dyn) - CALL WriteField_u('psfi',ps_dyn) - DO iq=1,nqtot - CALL WriteField_u('qfi'//trim(int2str(iq)),q_dyn(:,:,iq)) - ENDDO -END IF - - -!-jld - !$OMP MASTER - CALL resume_timer(timer_caldyn) - !$OMP END MASTER - - END SUBROUTINE call_calfis - -END MODULE call_calfis_mod Index: LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90 (revision 5268) @@ -0,0 +1,418 @@ +!#define DEBUG_IO +MODULE call_calfis_mod + + REAL,POINTER,SAVE :: ucov(:,:) + REAL,POINTER,SAVE :: vcov(:,:) + REAL,POINTER,SAVE :: teta(:,:) + REAL,POINTER,SAVE :: masse(:,:) + REAL,POINTER,SAVE :: ps(:) + REAL,POINTER,SAVE :: phis(:) + REAL,POINTER,SAVE :: q(:,:,:) + REAL,POINTER,SAVE :: flxw(:,:) + + REAL,POINTER,SAVE :: p(:,:) + REAL,POINTER,SAVE :: pks(:) + REAL,POINTER,SAVE :: pk(:,:) + REAL,POINTER,SAVE :: pkf(:,:) + REAL,POINTER,SAVE :: phi(:,:) + REAL,POINTER,SAVE :: du(:,:) + REAL,POINTER,SAVE :: dv(:,:) + REAL,POINTER,SAVE :: dteta(:,:) + REAL,POINTER,SAVE :: dq(:,:,:) + REAL,POINTER,SAVE :: dufi(:,:) + REAL,POINTER,SAVE :: dvfi(:,:) + REAL,POINTER,SAVE :: dtetafi(:,:) + REAL,POINTER,SAVE :: dqfi(:,:,:) + REAL,POINTER,SAVE :: dpfi(:) + + + + + +CONTAINS + + SUBROUTINE call_calfis_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + USE infotrac, ONLY: nqtot + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_physic + + CALL allocate_u(ucov,llm,d) + CALL allocate_v(vcov,llm,d) + CALL allocate_u(teta,llm,d) + CALL allocate_u(masse,llm,d) + CALL allocate_u(ps,d) + CALL allocate_u(phis,d) + CALL allocate_u(q,llm,nqtot,d) + CALL allocate_u(flxw,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(pks,d) + pks(:)=0 + CALL allocate_u(pk,llm,d) + pk(:,:)=0 + CALL allocate_u(pkf,llm,d) + CALL allocate_u(phi,llm,d) + CALL allocate_u(du,llm,d) + CALL allocate_v(dv,llm,d) + CALL allocate_u(dteta,llm,d) + CALL allocate_u(dq,llm,nqtot,d) + CALL allocate_u(dufi,llm,d) + CALL allocate_v(dvfi,llm,d) + CALL allocate_u(dtetafi,llm,d) + CALL allocate_u(dqfi,llm,nqtot,d) + CALL allocate_u(dpfi,d) + + END SUBROUTINE call_calfis_allocate + + + SUBROUTINE call_calfis(itau,lafin,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, & + phis_dyn,q_dyn,flxw_dyn) + USE dimensions_mod + use exner_hyb_loc_m, only: exner_hyb_loc + use exner_milieu_loc_m, only: exner_milieu_loc + USE parallel_lmdz + USE times + USE mod_hallo + USE Bands + USE vampir + USE infotrac, ONLY: nqtot + USE control_mod + USE write_field_loc + USE write_field + USE comconst_mod, ONLY: dtphys + USE logic_mod, ONLY: leapf, forward, ok_strato + USE comvert_mod, ONLY: ap, bp, pressure_exner + USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS, CPPKEY_DEBUGIO + USE strings_mod, ONLY: int2str + + IMPLICIT NONE + INCLUDE "iniprint.h" + + INTEGER,INTENT(IN) :: itau ! (time) iteration step number + LOGICAL,INTENT(IN) :: lafin ! .true. if final time step + REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind + REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind + REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature + REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass + REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure + REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential + REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers + REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux + + REAL :: dufi_tmp(iip1,llm) + REAL :: dvfi_tmp(iip1,llm) + REAL :: dtetafi_tmp(iip1,llm) + REAL :: dpfi_tmp(iip1) + REAL :: dqfi_tmp(iip1,llm,nqtot) + + REAL :: jD_cur, jH_cur + CHARACTER(LEN=15) :: ztit + TYPE(Request),SAVE :: Request_physic +!$OMP THREADPRIVATE(Request_physic ) + INTEGER :: ijb,ije,l,iq + + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) + ENDDO +END IF + +! +! ....... Ajout P.Le Van ( 17/04/96 ) ........... +! + + + !$OMP MASTER + CALL suspend_timer(timer_caldyn) + IF (prt_level >= 10) THEN + WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau + ENDIF + !$OMP END MASTER + + jD_cur = jD_ref + day_ini - day_ref & + & + (itau+1)/day_step + + IF (planet_type .eq."generic") THEN + ! AS: we make jD_cur to be pday + jD_cur = int(day_ini + itau/day_step) + ENDIF + + jH_cur = jH_ref + start_time + & + & mod(itau+1,day_step)/float(day_step) + if (jH_cur > 1.0 ) then + jD_cur = jD_cur +1. + jH_cur = jH_cur -1. + endif + +! Inbterface avec les routines de phylmd (phymars ... ) +! ----------------------------------------------------- + +!+jld + +! Diagnostique de conservation de l'energie : initialisation + +!-jld + !$OMP BARRIER + !$OMP MASTER + CALL VTb(VThallo) + !$OMP END MASTER + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) +END IF + + CALL SetTag(Request_physic,800) + CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2) + CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2) + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL Set_Distrib(distrib_Physic) + CALL VTe(VThallo) + + CALL VTb(VTphysiq) + !$OMP END MASTER + !$OMP BARRIER + + CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) + + !$OMP BARRIER + CALL exner_hyb_loc( ip1jmp1, ps, p, pks, pk, pkf ) + !$OMP BARRIER + CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi ) + + + CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic) + CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic) + CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic) + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) + ENDDO +END IF + + !$OMP BARRIER + +IF (CPPKEY_PHYS) THEN + CALL calfis_loc(lafin ,jD_cur, jH_cur, & + ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , & + du,dv,dteta,dq, & + flxw, dufi,dvfi,dtetafi,dqfi,dpfi ) +END IF + ijb=ij_begin + ije=ij_end + IF ( .not. pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) + dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) + dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) + dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) + !$OMP END MASTER + + ENDIF ! of if ( .not. pole_nord) + + !$OMP BARRIER + !$OMP MASTER + CALL Set_Distrib(distrib_Physic_bis) + CALL VTb(VThallo) + !$OMP END MASTER + !$OMP BARRIER + + CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic) + + DO iq=1,nqtot + CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic) + ENDDO + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VThallo) + CALL Set_Distrib(distrib_Physic) + !$OMP END MASTER + !$OMP BARRIER + ijb=ij_begin + IF (.not. pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) + dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) + dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l) + dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:) + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) + !$OMP END MASTER + + endif ! of if (.not. pole_nord) + + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('dufi',dufi) + CALL WriteField_v('dvfi',dvfi) + CALL WriteField_u('dtetafi',dtetafi) + CALL WriteField_u('dpfi',dpfi) + DO iq=1,nqtot + CALL WriteField_u('dqfi'//trim(int2str(iq)),dqfi(:,:,iq)) + ENDDO +END IF + + !$OMP BARRIER + +! ajout des tendances physiques: +! ------------------------------ +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) + ENDDO +END IF + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) + ENDDO +END IF + + CALL addfi_loc( dtphys, leapf, forward , & + ucov, vcov, teta , q ,ps , & + dufi, dvfi, dtetafi , dqfi ,dpfi ) + ! since addfi updates ps(), also update p(), masse() and pk() + CALL pression_loc(ip1jmp1,ap,bp,ps,p) +!$OMP BARRIER + CALL massdair_loc(p,masse) +!$OMP BARRIER + if (pressure_exner) then + CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf) + else + CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf) + endif +!$OMP BARRIER + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq)) + ENDDO +END IF + + IF (ok_strato) THEN +! CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + CALL top_bound_loc(vcov,ucov,teta,masse,dtphys) + ENDIF + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VTphysiq) + CALL VTb(VThallo) + !$OMP END MASTER + + CALL SetTag(Request_physic,800) + CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic) + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VThallo) + CALL set_distrib(distrib_caldyn) + !$OMP END MASTER + !$OMP BARRIER + +! +! Diagnostique de conservation de l'energie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' +! CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!" + ENDIF + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('ucovfi',ucov_dyn) + CALL WriteField_v('vcovfi',vcov_dyn) + CALL WriteField_u('tetafi',teta_dyn) + CALL WriteField_u('psfi',ps_dyn) + DO iq=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(iq)),q_dyn(:,:,iq)) + ENDDO +END IF + + +!-jld + !$OMP MASTER + CALL resume_timer(timer_caldyn) + !$OMP END MASTER + + END SUBROUTINE call_calfis + +END MODULE call_calfis_mod Index: LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.F90 (revision 5267) +++ (revision ) @@ -1,326 +1,0 @@ -MODULE call_dissip_mod - - REAL,POINTER,SAVE :: ucov(:,:) - REAL,POINTER,SAVE :: vcov(:,:) - REAL,POINTER,SAVE :: teta(:,:) - REAL,POINTER,SAVE :: p(:,: ) - REAL,POINTER,SAVE :: pk(:,:) - - REAL,POINTER,SAVE :: ucont(:,:) - REAL,POINTER,SAVE :: vcont(:,:) - REAL,POINTER,SAVE :: ecin(:,:) - REAL,POINTER,SAVE :: ecin0(:,:) - REAL,POINTER,SAVE :: dudis(:,:) - REAL,POINTER,SAVE :: dvdis(:,:) - REAL,POINTER,SAVE :: dtetadis(:,:) - REAL,POINTER,SAVE :: dtetaecdt(:,:) - - - -CONTAINS - - SUBROUTINE call_dissip_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - USE dissip_mod, ONLY : dissip_allocate - IMPLICIT NONE - TYPE(distrib),POINTER :: d - d=>distrib_dissip - - CALL allocate_u(ucov,llm,d) - ucov(:,:)=0 - CALL allocate_v(vcov,llm,d) - vcov(:,:)=0 - CALL allocate_u(teta,llm,d) - CALL allocate_u(p,llmp1,d) - CALL allocate_u(pk,llm,d) - CALL allocate_u(ucont,llm,d) - CALL allocate_v(vcont,llm,d) - CALL allocate_u(ecin,llm,d) - CALL allocate_u(ecin0,llm,d) - CALL allocate_u(dudis,llm,d) - CALL allocate_v(dvdis,llm,d) - CALL allocate_u(dtetadis,llm,d) - CALL allocate_u(dtetaecdt,llm,d) - - - CALL dissip_allocate - - END SUBROUTINE call_dissip_allocate - - SUBROUTINE call_dissip_switch_dissip(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE dissip_mod, ONLY : dissip_switch_dissip - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_u(ucov,distrib_dissip,dist) - CALL switch_v(vcov,distrib_dissip,dist) - CALL switch_u(teta,distrib_dissip,dist) - CALL switch_u(p,distrib_dissip,dist) - CALL switch_u(pk,distrib_dissip,dist) - CALL switch_u(ucont,distrib_dissip,dist) - CALL switch_v(vcont,distrib_dissip,dist) - CALL switch_u(ecin,distrib_dissip,dist) - CALL switch_u(ecin0,distrib_dissip,dist) - CALL switch_u(dudis,distrib_dissip,dist) - CALL switch_v(dvdis,distrib_dissip,dist) - CALL switch_u(dtetadis,distrib_dissip,dist) - CALL switch_u(dtetaecdt,distrib_dissip,dist) - - CALL dissip_switch_dissip(dist) - - END SUBROUTINE call_dissip_switch_dissip - - - - SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn) - USE dimensions_mod - USE parallel_lmdz - USE times - USE mod_hallo - USE Bands - USE vampir - USE write_field_loc - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - IMPLICIT NONE - INCLUDE 'comgeom.h' - REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind - REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind - REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! covariant meridional wind - REAL,INTENT(INOUT) :: p_dyn(ijb_u:ije_u,llmp1 ) ! pressure at interlayer - REAL,INTENT(INOUT) :: pk_dyn(ijb_u:ije_u,llm) ! Exner at midlayer - REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure - REAL :: tppn(iim),tpps(iim) - REAL :: tpn,tps - - REAL SSUM - LOGICAL,PARAMETER :: dissip_conservative=.TRUE. - TYPE(Request),SAVE :: Request_dissip -!$OMP THREADPRIVATE(Request_dissip ) - INTEGER :: ij,l,ijb,ije - - - !$OMP MASTER - CALL suspend_timer(timer_caldyn) - -! print*,'Entree dans la dissipation : Iteration No ',true_itau -! calcul de l'energie cinetique avant dissipation -! print *,'Passage dans la dissipation' - - CALL VTb(VThallo) - !$OMP END MASTER - - !$OMP BARRIER - - CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1) - CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1) - CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip) - CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip) - CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip) - - CALL SendRequest(Request_dissip) - !$OMP BARRIER - CALL WaitRequest(Request_dissip) - - !$OMP BARRIER - !$OMP MASTER - CALL set_distrib(distrib_dissip) - CALL VTe(VThallo) - CALL VTb(VTdissipation) - CALL start_timer(timer_dissip) - !$OMP END MASTER - !$OMP BARRIER - - CALL covcont_loc(llm,ucov,vcov,ucont,vcont) - CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0) - -! dissipation - -! CALL FTRACE_REGION_BEGIN("dissip") - CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis) - -IF (CPPKEY_DEBUGIO) THEN - CALL WriteField_u('dudis',dudis) - CALL WriteField_v('dvdis',dvdis) - CALL WriteField_u('dtetadis',dtetadis) -END IF - -! CALL FTRACE_REGION_END("dissip") - - ijb=ij_begin - ije=ij_end - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) - ENDDO - !$OMP END DO NOWAIT - - IF (pole_sud) ije=ije-iip1 - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) - ENDDO - !$OMP END DO NOWAIT - -! teta=teta+dtetadis - - -!------------------------------------------------------------------------ - IF (dissip_conservative) THEN -! On rajoute la tendance due a la transform. Ec -> E therm. cree -! lors de la dissipation - !$OMP BARRIER - !$OMP MASTER - CALL suspend_timer(timer_dissip) - CALL VTb(VThallo) - !$OMP END MASTER - CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip) - CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip) - CALL SendRequest(Request_Dissip) - !$OMP BARRIER - CALL WaitRequest(Request_Dissip) - !$OMP MASTER - CALL VTe(VThallo) - CALL resume_timer(timer_dissip) - !$OMP END MASTER - !$OMP BARRIER - CALL covcont_loc(llm,ucov,vcov,ucont,vcont) - CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) - - ijb=ij_begin - ije=ij_end - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije - dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) - dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) - ENDDO - ENDDO - !$OMP END DO NOWAIT - - ENDIF - - ijb=ij_begin - ije=ij_end - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - DO ij=ijb,ije - teta(ij,l)=teta(ij,l)+dtetadis(ij,l) - ENDDO - ENDDO - !$OMP END DO NOWAIT - -!------------------------------------------------------------------------ - - -! ....... P. Le Van ( ajout le 17/04/96 ) ........... -! ... Calcul de la valeur moyenne, unique de h aux poles ..... -! - - ijb=ij_begin - ije=ij_end - - IF (pole_nord) THEN - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llm - DO ij = 1,iim - tppn(ij) = aire( ij ) * teta( ij ,l) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - - DO ij = 1, iip1 - teta( ij ,l) = tpn - ENDDO - ENDDO - !$OMP END DO NOWAIT - - if (1 == 0) then -!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics -!!! 2) should probably not be here anyway -!!! but are kept for those who would want to revert to previous behaviour - !$OMP MASTER - DO ij = 1,iim - tppn(ij) = aire( ij ) * ps_dyn ( ij ) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - - DO ij = 1, iip1 - ps_dyn( ij ) = tpn - ENDDO - !$OMP END MASTER - - ENDIF ! of if (1 == 0) - endif ! of of (pole_nord) - - IF (pole_sud) THEN - - !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llm - DO ij = 1,iim - tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) - ENDDO - - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - teta(ij+ip1jm,l) = tps - ENDDO - ENDDO - !$OMP END DO NOWAIT - - if (1 == 0) then -!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics -!!! 2) should probably not be here anyway -!!! but are kept for those who would want to revert to previous behaviour - !$OMP MASTER - DO ij = 1,iim - tpps(ij) = aire(ij+ip1jm) * ps_dyn (ij+ip1jm) - ENDDO - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - ps_dyn(ij+ip1jm) = tps - ENDDO - !$OMP END MASTER - ENDIF ! of if (1 == 0) - endif ! of if (pole_sud) - - - !$OMP BARRIER - !$OMP MASTER - CALL VTe(VTdissipation) - CALL stop_timer(timer_dissip) - CALL VTb(VThallo) - !$OMP END MASTER - - CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip) - CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip) - CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip) - CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip) - CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip) - - CALL SendRequest(Request_dissip) - - !$OMP BARRIER - CALL WaitRequest(Request_dissip) - !$OMP BARRIER - !$OMP MASTER - CALL set_distrib(distrib_caldyn) - CALL VTe(VThallo) - CALL resume_timer(timer_caldyn) -! print *,'fin dissipation' - !$OMP END MASTER - !$OMP BARRIER - - - END SUBROUTINE call_dissip - -END MODULE call_dissip_mod Index: LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90 (revision 5268) @@ -0,0 +1,326 @@ +MODULE call_dissip_mod + + REAL,POINTER,SAVE :: ucov(:,:) + REAL,POINTER,SAVE :: vcov(:,:) + REAL,POINTER,SAVE :: teta(:,:) + REAL,POINTER,SAVE :: p(:,: ) + REAL,POINTER,SAVE :: pk(:,:) + + REAL,POINTER,SAVE :: ucont(:,:) + REAL,POINTER,SAVE :: vcont(:,:) + REAL,POINTER,SAVE :: ecin(:,:) + REAL,POINTER,SAVE :: ecin0(:,:) + REAL,POINTER,SAVE :: dudis(:,:) + REAL,POINTER,SAVE :: dvdis(:,:) + REAL,POINTER,SAVE :: dtetadis(:,:) + REAL,POINTER,SAVE :: dtetaecdt(:,:) + + + +CONTAINS + + SUBROUTINE call_dissip_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + USE dissip_mod, ONLY : dissip_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(ucov,llm,d) + ucov(:,:)=0 + CALL allocate_v(vcov,llm,d) + vcov(:,:)=0 + CALL allocate_u(teta,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(pk,llm,d) + CALL allocate_u(ucont,llm,d) + CALL allocate_v(vcont,llm,d) + CALL allocate_u(ecin,llm,d) + CALL allocate_u(ecin0,llm,d) + CALL allocate_u(dudis,llm,d) + CALL allocate_v(dvdis,llm,d) + CALL allocate_u(dtetadis,llm,d) + CALL allocate_u(dtetaecdt,llm,d) + + + CALL dissip_allocate + + END SUBROUTINE call_dissip_allocate + + SUBROUTINE call_dissip_switch_dissip(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE dissip_mod, ONLY : dissip_switch_dissip + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(ucov,distrib_dissip,dist) + CALL switch_v(vcov,distrib_dissip,dist) + CALL switch_u(teta,distrib_dissip,dist) + CALL switch_u(p,distrib_dissip,dist) + CALL switch_u(pk,distrib_dissip,dist) + CALL switch_u(ucont,distrib_dissip,dist) + CALL switch_v(vcont,distrib_dissip,dist) + CALL switch_u(ecin,distrib_dissip,dist) + CALL switch_u(ecin0,distrib_dissip,dist) + CALL switch_u(dudis,distrib_dissip,dist) + CALL switch_v(dvdis,distrib_dissip,dist) + CALL switch_u(dtetadis,distrib_dissip,dist) + CALL switch_u(dtetaecdt,distrib_dissip,dist) + + CALL dissip_switch_dissip(dist) + + END SUBROUTINE call_dissip_switch_dissip + + + + SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn) + USE dimensions_mod + USE parallel_lmdz + USE times + USE mod_hallo + USE Bands + USE vampir + USE write_field_loc + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + IMPLICIT NONE + INCLUDE 'comgeom.h' + REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind + REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind + REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! covariant meridional wind + REAL,INTENT(INOUT) :: p_dyn(ijb_u:ije_u,llmp1 ) ! pressure at interlayer + REAL,INTENT(INOUT) :: pk_dyn(ijb_u:ije_u,llm) ! Exner at midlayer + REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure + REAL :: tppn(iim),tpps(iim) + REAL :: tpn,tps + + REAL SSUM + LOGICAL,PARAMETER :: dissip_conservative=.TRUE. + TYPE(Request),SAVE :: Request_dissip +!$OMP THREADPRIVATE(Request_dissip ) + INTEGER :: ij,l,ijb,ije + + + !$OMP MASTER + CALL suspend_timer(timer_caldyn) + +! print*,'Entree dans la dissipation : Iteration No ',true_itau +! calcul de l'energie cinetique avant dissipation +! print *,'Passage dans la dissipation' + + CALL VTb(VThallo) + !$OMP END MASTER + + !$OMP BARRIER + + CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1) + CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1) + CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip) + CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip) + CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip) + + CALL SendRequest(Request_dissip) + !$OMP BARRIER + CALL WaitRequest(Request_dissip) + + !$OMP BARRIER + !$OMP MASTER + CALL set_distrib(distrib_dissip) + CALL VTe(VThallo) + CALL VTb(VTdissipation) + CALL start_timer(timer_dissip) + !$OMP END MASTER + !$OMP BARRIER + + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0) + +! dissipation + +! CALL FTRACE_REGION_BEGIN("dissip") + CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + +IF (CPPKEY_DEBUGIO) THEN + CALL WriteField_u('dudis',dudis) + CALL WriteField_v('dvdis',dvdis) + CALL WriteField_u('dtetadis',dtetadis) +END IF + +! CALL FTRACE_REGION_END("dissip") + + ijb=ij_begin + ije=ij_end + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + + IF (pole_sud) ije=ije-iip1 + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + +! teta=teta+dtetadis + + +!------------------------------------------------------------------------ + IF (dissip_conservative) THEN +! On rajoute la tendance due a la transform. Ec -> E therm. cree +! lors de la dissipation + !$OMP BARRIER + !$OMP MASTER + CALL suspend_timer(timer_dissip) + CALL VTb(VThallo) + !$OMP END MASTER + CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip) + CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip) + CALL SendRequest(Request_Dissip) + !$OMP BARRIER + CALL WaitRequest(Request_Dissip) + !$OMP MASTER + CALL VTe(VThallo) + CALL resume_timer(timer_dissip) + !$OMP END MASTER + !$OMP BARRIER + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) + + ijb=ij_begin + ije=ij_end + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) + dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) + ENDDO + ENDDO + !$OMP END DO NOWAIT + + ENDIF + + ijb=ij_begin + ije=ij_end + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + teta(ij,l)=teta(ij,l)+dtetadis(ij,l) + ENDDO + ENDDO + !$OMP END DO NOWAIT + +!------------------------------------------------------------------------ + + +! ....... P. Le Van ( ajout le 17/04/96 ) ........... +! ... Calcul de la valeur moyenne, unique de h aux poles ..... +! + + ijb=ij_begin + ije=ij_end + + IF (pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + ENDDO + !$OMP END DO NOWAIT + + if (1 == 0) then +!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics +!!! 2) should probably not be here anyway +!!! but are kept for those who would want to revert to previous behaviour + !$OMP MASTER + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps_dyn ( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + ps_dyn( ij ) = tpn + ENDDO + !$OMP END MASTER + + ENDIF ! of if (1 == 0) + endif ! of of (pole_nord) + + IF (pole_sud) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO + !$OMP END DO NOWAIT + + if (1 == 0) then +!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics +!!! 2) should probably not be here anyway +!!! but are kept for those who would want to revert to previous behaviour + !$OMP MASTER + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * ps_dyn (ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps_dyn(ij+ip1jm) = tps + ENDDO + !$OMP END MASTER + ENDIF ! of if (1 == 0) + endif ! of if (pole_sud) + + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VTdissipation) + CALL stop_timer(timer_dissip) + CALL VTb(VThallo) + !$OMP END MASTER + + CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip) + + CALL SendRequest(Request_dissip) + + !$OMP BARRIER + CALL WaitRequest(Request_dissip) + !$OMP BARRIER + !$OMP MASTER + CALL set_distrib(distrib_caldyn) + CALL VTe(VThallo) + CALL resume_timer(timer_caldyn) +! print *,'fin dissipation' + !$OMP END MASTER + !$OMP BARRIER + + + END SUBROUTINE call_dissip + +END MODULE call_dissip_mod Index: LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.F90 (revision 5267) +++ (revision ) @@ -1,194 +1,0 @@ -SUBROUTINE check_isotopes(q, ijb, ije, err_msg) - USE parallel_lmdz - USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str - USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & - ntiso, iH2O, nzone, tracers, isoName, itZonIso - USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO - USE ioipsl, ONLY: getin - IMPLICIT NONE - include "dimensions.h" - REAL, INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot) - INTEGER, INTENT(IN) :: ijb, ije !--- Can be local and different from ijb_u,ije_u, for example in qminimum - CHARACTER(LEN=*), INTENT(IN) :: err_msg !--- Error message to display - CHARACTER(LEN=maxlen) :: modname, msg1, nm(2) - INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar - INTEGER, ALLOCATABLE :: ix(:) - REAL, ALLOCATABLE, SAVE :: tnat(:) !--- OpenMP shared variable - REAL :: xtractot, xiiso, deltaD, q1, q2 - REAL, PARAMETER :: borne = 1e19, & - errmax = 1e-8, & !--- Max. absolute error - errmaxrel = 1e-3, & !--- Max. relative error - qmin = 1e-11, & - deltaDmax =1000.0, & - deltaDmin =-999.0, & - ridicule = 1e-12 - INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO -!$OMP THREADPRIVATE(iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO) - LOGICAL :: ltnat1 - LOGICAL, SAVE :: first=.TRUE. -!$OMP THREADPRIVATE(first) - - modname='check_isotopes' - IF(.NOT.isoCheck) RETURN !--- No need to check => finished - IF(isoSelect('H2O')) RETURN !--- No H2O isotopes group found - IF(niso == 0) RETURN !--- No isotopes => finished - IF(first) THEN -!$OMP MASTER - ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1) - ALLOCATE(tnat(niso)) - iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O - iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O - iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O - iso_HDO = strIdx(isoName,'HDO'); IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO - iso_HTO = strIdx(isoName,'HTO'); IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO - IF(ltnat1) tnat(:) = 1.0 -!$OMP END MASTER -!$OMP BARRIER - first = .FALSE. - END IF - CALL msg('31: err_msg='//TRIM(err_msg), modname) - - !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS) - modname = 'check_isotopes:iso_verif_noNaN' - DO ixt = 1, ntiso - DO ipha = 1, nphas - iq = iqIsoPha(ixt,ipha) -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO k = 1, llm - DO i = ijb, ije - IF(ABS(q(i,k,iq)) < borne) CYCLE - WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq) - CALL msg(msg1, modname) - CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) - END DO - END DO -!$OMP END DO NOWAIT - END DO - END DO - - !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL) - modname = 'check_isotopes:iso_verif_egalite' - ixt = iso_eau - IF(ixt /= 0) THEN - DO ipha = 1, nphas - iq = iqIsoPha(ixt,ipha) - iqpar = tracers(iq)%iqParent -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO k = 1, llm - DO i = ijb, ije - q1 = q(i,k,iqpar) - q2 = q(i,k,iq) -!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form. -! This would be probably required to sum from smallest to highest concentrations ; the corresponding -! indices vector can be computed once only (in the initializations stage), using mean concentrations. -! q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3) - IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN - q(i,k,iq) = q1 !--- Bidouille pour convergence -! q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2 - CYCLE - END IF - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) - END DO - END DO -!$OMP END DO NOWAIT - END DO - END IF - - !--- CHECK DELTA ANOMALIES - modname = 'check_isotopes:iso_verif_aberrant' - ix = [ iso_HDO , iso_O18 ] - nm = ['deltaD ', 'deltaO18'] - DO iiso = 1, SIZE(ix) - ixt = ix(iiso) - IF(ixt == 0) CYCLE - DO ipha = 1, nphas - iq = iqIsoPha(ixt,ipha) - iqpar = tracers(iq)%iqParent -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO k = 1, llm - DO i = ijb, ije - q1 = q(i,k,iqpar) - q2 = q(i,k,iq) -!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form. -! This would be probably required to sum from smallest to highest concentrations ; the corresponding -! indices vector can be computed once only (in the initializations stage), using mean concentrations. -! q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3) - IF(q2 <= qmin) CYCLE - deltaD = (q2/q1/tnat(ixt)-1.)*1000. - IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname) - CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) - END DO - END DO -!$OMP END DO NOWAIT - END DO - END DO - - IF(nzone == 0) RETURN - - !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES - modname = 'check_isotopes:iso_verif_aberrant' - IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN - DO izon = 1, nzone - ixt = itZonIso(izon, iso_HDO) - ieau = itZonIso(izon, iso_eau) - DO ipha = 1, nphas - iq = iqIsoPha(ixt, ipha) - iqeau = iqIsoPha(ieau, ipha) -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO k = 1, llm - DO i = ijb, ije - q1 = q(i,k,iqeau) - q2 = q(i,k,iq) - IF(q2<=qmin) CYCLE - deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000. - IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname) - CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname) - CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) - END DO - END DO -!$OMP END DO NOWAIT - END DO - END DO - END IF - - !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL) - DO iiso = 1, niso - DO ipha = 1, nphas - iq = iqIsoPha(iiso, ipha) -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO k = 1, llm - DO i = ijb, ije - xiiso = q(i,k,iq) - xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha))) - IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN - CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg)) - CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname) - CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname) - CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) - END IF - IF(ABS(xtractot) <= ridicule) CYCLE - DO izon = 1, nzone - q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence - END DO - END DO - END DO -!$OMP END DO NOWAIT - END DO - END DO - -END SUBROUTINE check_isotopes - Index: LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90 (revision 5268) @@ -0,0 +1,194 @@ +SUBROUTINE check_isotopes(q, ijb, ije, err_msg) + USE parallel_lmdz + USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str + USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & + ntiso, iH2O, nzone, tracers, isoName, itZonIso + USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO + USE ioipsl, ONLY: getin + IMPLICIT NONE + include "dimensions.h" + REAL, INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot) + INTEGER, INTENT(IN) :: ijb, ije !--- Can be local and different from ijb_u,ije_u, for example in qminimum + CHARACTER(LEN=*), INTENT(IN) :: err_msg !--- Error message to display + CHARACTER(LEN=maxlen) :: modname, msg1, nm(2) + INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar + INTEGER, ALLOCATABLE :: ix(:) + REAL, ALLOCATABLE, SAVE :: tnat(:) !--- OpenMP shared variable + REAL :: xtractot, xiiso, deltaD, q1, q2 + REAL, PARAMETER :: borne = 1e19, & + errmax = 1e-8, & !--- Max. absolute error + errmaxrel = 1e-3, & !--- Max. relative error + qmin = 1e-11, & + deltaDmax =1000.0, & + deltaDmin =-999.0, & + ridicule = 1e-12 + INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO +!$OMP THREADPRIVATE(iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO) + LOGICAL :: ltnat1 + LOGICAL, SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + modname='check_isotopes' + IF(.NOT.isoCheck) RETURN !--- No need to check => finished + IF(isoSelect('H2O')) RETURN !--- No H2O isotopes group found + IF(niso == 0) RETURN !--- No isotopes => finished + IF(first) THEN +!$OMP MASTER + ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1) + ALLOCATE(tnat(niso)) + iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O + iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O + iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O + iso_HDO = strIdx(isoName,'HDO'); IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO + iso_HTO = strIdx(isoName,'HTO'); IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO + IF(ltnat1) tnat(:) = 1.0 +!$OMP END MASTER +!$OMP BARRIER + first = .FALSE. + END IF + CALL msg('31: err_msg='//TRIM(err_msg), modname) + + !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS) + modname = 'check_isotopes:iso_verif_noNaN' + DO ixt = 1, ntiso + DO ipha = 1, nphas + iq = iqIsoPha(ixt,ipha) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO i = ijb, ije + IF(ABS(q(i,k,iq)) < borne) CYCLE + WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq) + CALL msg(msg1, modname) + CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) + END DO + END DO +!$OMP END DO NOWAIT + END DO + END DO + + !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL) + modname = 'check_isotopes:iso_verif_egalite' + ixt = iso_eau + IF(ixt /= 0) THEN + DO ipha = 1, nphas + iq = iqIsoPha(ixt,ipha) + iqpar = tracers(iq)%iqParent +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO i = ijb, ije + q1 = q(i,k,iqpar) + q2 = q(i,k,iq) +!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form. +! This would be probably required to sum from smallest to highest concentrations ; the corresponding +! indices vector can be computed once only (in the initializations stage), using mean concentrations. +! q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3) + IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN + q(i,k,iq) = q1 !--- Bidouille pour convergence +! q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2 + CYCLE + END IF + CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(int2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) + CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) + END DO + END DO +!$OMP END DO NOWAIT + END DO + END IF + + !--- CHECK DELTA ANOMALIES + modname = 'check_isotopes:iso_verif_aberrant' + ix = [ iso_HDO , iso_O18 ] + nm = ['deltaD ', 'deltaO18'] + DO iiso = 1, SIZE(ix) + ixt = ix(iiso) + IF(ixt == 0) CYCLE + DO ipha = 1, nphas + iq = iqIsoPha(ixt,ipha) + iqpar = tracers(iq)%iqParent +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO i = ijb, ije + q1 = q(i,k,iqpar) + q2 = q(i,k,iq) +!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form. +! This would be probably required to sum from smallest to highest concentrations ; the corresponding +! indices vector can be computed once only (in the initializations stage), using mean concentrations. +! q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3) + IF(q2 <= qmin) CYCLE + deltaD = (q2/q1/tnat(ixt)-1.)*1000. + IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE + CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(int2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) + CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname) + CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) + END DO + END DO +!$OMP END DO NOWAIT + END DO + END DO + + IF(nzone == 0) RETURN + + !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES + modname = 'check_isotopes:iso_verif_aberrant' + IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN + DO izon = 1, nzone + ixt = itZonIso(izon, iso_HDO) + ieau = itZonIso(izon, iso_eau) + DO ipha = 1, nphas + iq = iqIsoPha(ixt, ipha) + iqeau = iqIsoPha(ieau, ipha) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO i = ijb, ije + q1 = q(i,k,iqeau) + q2 = q(i,k,iq) + IF(q2<=qmin) CYCLE + deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000. + IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE + CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname) + CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname) + msg1 = '('//TRIM(strStack(int2str([i,k])))//')' + CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) + CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname) + CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) + END DO + END DO +!$OMP END DO NOWAIT + END DO + END DO + END IF + + !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL) + DO iiso = 1, niso + DO ipha = 1, nphas + iq = iqIsoPha(iiso, ipha) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO i = ijb, ije + xiiso = q(i,k,iq) + xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha))) + IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN + CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg)) + CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname) + CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname) + CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) + END IF + IF(ABS(xtractot) <= ridicule) CYCLE + DO izon = 1, nzone + q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence + END DO + END DO + END DO +!$OMP END DO NOWAIT + END DO + END DO + +END SUBROUTINE check_isotopes + Index: LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.F90 (revision 5267) +++ (revision ) @@ -1,37 +1,0 @@ -SUBROUTINE convmas1_loc (pbaru, pbarv, convm) -! -!------------------------------------------------------------------------------- -! Authors: P. Le Van , Fr. Hourdin. -!------------------------------------------------------------------------------- -! Purpose: Compute mass flux convergence at p levels. -! Equivalent to convmas_loc if convmas2_loc is called after. - USE parallel_lmdz - USE mod_filtreg_p - IMPLICIT NONE - include "dimensions.h" - include "paramet.h" - include "comgeom.h" -!=============================================================================== -! Arguments: - REAL, INTENT(IN) :: pbaru(ijb_u:ije_u,llm) - REAL, INTENT(IN) :: pbarv(ijb_v:ije_v,llm) - REAL, TARGET, INTENT(OUT) :: convm(ijb_u:ije_u,llm) -!=============================================================================== -! Method used: Computation from top to bottom. -! Mass convergence at level llm is equal to zero and is not stored in convm. -!=============================================================================== -! Local variables: - INTEGER :: l, jjb, jje -!=============================================================================== - -!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy ) - CALL convflu_loc( pbaru, pbarv, llm, convm ) - -!--- Filter - jjb=jj_begin - jje=jj_end+1 - IF(pole_sud) jje=jj_end - CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1) - -END SUBROUTINE convmas1_loc - Index: LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90 (revision 5268) @@ -0,0 +1,37 @@ +SUBROUTINE convmas1_loc (pbaru, pbarv, convm) +! +!------------------------------------------------------------------------------- +! Authors: P. Le Van , Fr. Hourdin. +!------------------------------------------------------------------------------- +! Purpose: Compute mass flux convergence at p levels. +! Equivalent to convmas_loc if convmas2_loc is called after. + USE parallel_lmdz + USE mod_filtreg_p + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comgeom.h" +!=============================================================================== +! Arguments: + REAL, INTENT(IN) :: pbaru(ijb_u:ije_u,llm) + REAL, INTENT(IN) :: pbarv(ijb_v:ije_v,llm) + REAL, TARGET, INTENT(OUT) :: convm(ijb_u:ije_u,llm) +!=============================================================================== +! Method used: Computation from top to bottom. +! Mass convergence at level llm is equal to zero and is not stored in convm. +!=============================================================================== +! Local variables: + INTEGER :: l, jjb, jje +!=============================================================================== + +!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy ) + CALL convflu_loc( pbaru, pbarv, llm, convm ) + +!--- Filter + jjb=jj_begin + jje=jj_end+1 + IF(pole_sud) jje=jj_end + CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1) + +END SUBROUTINE convmas1_loc + Index: LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.F90 (revision 5267) +++ (revision ) @@ -1,35 +1,0 @@ -SUBROUTINE convmas2_loc (convm) -! -!------------------------------------------------------------------------------- -! Authors: P. Le Van , Fr. Hourdin. -!------------------------------------------------------------------------------- -! Purpose: Compute mass flux convergence at p levels. -! Equivalent to convmas_loc if convmas1_loc is called before. - USE parallel_lmdz - IMPLICIT NONE - include "dimensions.h" - include "paramet.h" - include "comgeom.h" -!=============================================================================== -! Arguments: - REAL, INTENT(INOUT) :: convm(ijb_u:ije_u,llm) -!=============================================================================== -! Method used: Computation from top to bottom. -! Mass convergence at level llm is equal to zero and is not stored in convm. -!=============================================================================== -! Local variables: - INTEGER :: l, ijb, ije -!=============================================================================== - -!$OMP MASTER -!--- Mass convergence is integrated from top to bottom - ijb=ij_begin - ije=ij_end+iip1 - IF(pole_sud) ije=ij_end - DO l=llmm1,1,-1 - convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1) - END DO -!$OMP END MASTER - -END SUBROUTINE convmas2_loc - Index: LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90 (revision 5268) @@ -0,0 +1,35 @@ +SUBROUTINE convmas2_loc (convm) +! +!------------------------------------------------------------------------------- +! Authors: P. Le Van , Fr. Hourdin. +!------------------------------------------------------------------------------- +! Purpose: Compute mass flux convergence at p levels. +! Equivalent to convmas_loc if convmas1_loc is called before. + USE parallel_lmdz + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comgeom.h" +!=============================================================================== +! Arguments: + REAL, INTENT(INOUT) :: convm(ijb_u:ije_u,llm) +!=============================================================================== +! Method used: Computation from top to bottom. +! Mass convergence at level llm is equal to zero and is not stored in convm. +!=============================================================================== +! Local variables: + INTEGER :: l, ijb, ije +!=============================================================================== + +!$OMP MASTER +!--- Mass convergence is integrated from top to bottom + ijb=ij_begin + ije=ij_end+iip1 + IF(pole_sud) ije=ij_end + DO l=llmm1,1,-1 + convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1) + END DO +!$OMP END MASTER + +END SUBROUTINE convmas2_loc + Index: LMDZ6/trunk/libf/dyn3dmem/convmas_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas_loc.F90 (revision 5267) +++ (revision ) @@ -1,48 +1,0 @@ -SUBROUTINE convmas_loc (pbaru, pbarv, convm) -! -!------------------------------------------------------------------------------- -! Authors: P. Le Van , Fr. Hourdin. -!------------------------------------------------------------------------------- -! Purpose: Compute mass flux convergence at p levels. - USE parallel_lmdz - USE mod_filtreg_p - IMPLICIT NONE - include "dimensions.h" - include "paramet.h" - include "comgeom.h" -!=============================================================================== -! Arguments: - REAL, INTENT(IN) :: pbaru(ijb_u:ije_u,llm) - REAL, INTENT(IN) :: pbarv(ijb_v:ije_v,llm) - REAL, INTENT(OUT) :: convm(ijb_u:ije_u,llm) -!=============================================================================== -! Method used: Computation from top to bottom. -! Mass convergence at level llm is equal to zero and is not stored in convm. -!=============================================================================== -! Local variables: - INTEGER :: l, ijb, ije, jjb, jje -!=============================================================================== - -!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy ) - CALL convflu_loc( pbaru, pbarv, llm, convm ) - -!--- Filter - jjb=jj_begin - jje=jj_end+1 - IF(pole_sud) jje=jj_end - CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1) - -!--- Mass convergence is integrated from top to bottom -!$OMP BARRIER -!$OMP MASTER - ijb=ij_begin - ije=ij_end+iip1 - IF(pole_sud) ije=ij_end - DO l=llmm1,1,-1 - convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1) - END DO -!$OMP END MASTER -!$OMP BARRIER - -END SUBROUTINE convmas_loc - Index: LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90 (revision 5268) @@ -0,0 +1,48 @@ +SUBROUTINE convmas_loc (pbaru, pbarv, convm) +! +!------------------------------------------------------------------------------- +! Authors: P. Le Van , Fr. Hourdin. +!------------------------------------------------------------------------------- +! Purpose: Compute mass flux convergence at p levels. + USE parallel_lmdz + USE mod_filtreg_p + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comgeom.h" +!=============================================================================== +! Arguments: + REAL, INTENT(IN) :: pbaru(ijb_u:ije_u,llm) + REAL, INTENT(IN) :: pbarv(ijb_v:ije_v,llm) + REAL, INTENT(OUT) :: convm(ijb_u:ije_u,llm) +!=============================================================================== +! Method used: Computation from top to bottom. +! Mass convergence at level llm is equal to zero and is not stored in convm. +!=============================================================================== +! Local variables: + INTEGER :: l, ijb, ije, jjb, jje +!=============================================================================== + +!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy ) + CALL convflu_loc( pbaru, pbarv, llm, convm ) + +!--- Filter + jjb=jj_begin + jje=jj_end+1 + IF(pole_sud) jje=jj_end + CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1) + +!--- Mass convergence is integrated from top to bottom +!$OMP BARRIER +!$OMP MASTER + ijb=ij_begin + ije=ij_end+iip1 + IF(pole_sud) ije=ij_end + DO l=llmm1,1,-1 + convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1) + END DO +!$OMP END MASTER +!$OMP BARRIER + +END SUBROUTINE convmas_loc + Index: LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.F90 (revision 5267) +++ (revision ) @@ -1,4 +1,0 @@ -MODULE dimensions_mod - INCLUDE 'dimensions.h' - INCLUDE 'paramet.h' -END MODULE dimensions_mod Index: LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90 (revision 5268) @@ -0,0 +1,4 @@ +MODULE dimensions_mod + INCLUDE 'dimensions.h' + INCLUDE 'paramet.h' +END MODULE dimensions_mod Index: LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90 (revision 5267) +++ (revision ) @@ -1,235 +1,0 @@ -! -! $Id: $ -! -SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh ) - ! - USE parallel_lmdz - USE write_field_loc - USE dissip_mod, ONLY: dissip_allocate - USE comconst_mod, ONLY: dtdiss - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO - IMPLICIT NONE - - - ! .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... - ! ( 10/01/98 ) - - !======================================================================= - ! - ! Auteur: P. Le Van - ! ------- - ! - ! Objet: - ! ------ - ! - ! Dissipation horizontale - ! - !======================================================================= - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - include "dimensions.h" - include "paramet.h" - include "comgeom.h" - include "comdissnew.h" - include "comdissipn.h" - - ! Arguments: - ! ---------- - - REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind - REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind - REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature - REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure - ! ! tendencies (.../s) on covariant winds and potential temperature - REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) - REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) - REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm) - - ! Local: - ! ------ - - REAL :: gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm) - REAL :: grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm) - REAL :: te1dt(llm),te2dt(llm),te3dt(llm) - REAL :: deltapres(ijb_u:ije_u,llm) - - INTEGER :: l,ij - - REAL :: SSUM - integer :: ijb,ije - - LOGICAl,SAVE :: first=.TRUE. -!$OMP THREADPRIVATE(first) - - IF (first) THEN - CALL dissip_allocate - first=.FALSE. - ENDIF - !----------------------------------------------------------------------- - ! initialisations: - ! ---------------- - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - te1dt(l) = tetaudiv(l) * dtdiss - te2dt(l) = tetaurot(l) * dtdiss - te3dt(l) = tetah(l) * dtdiss - ENDDO -!$OMP END DO NOWAIT - ! CALL initial0( ijp1llm, du ) - ! CALL initial0( ijmllm , dv ) - ! CALL initial0( ijp1llm, dh ) - - ijb=ij_begin - ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - du(ijb:ije,l)=0 - dh(ijb:ije,l)=0 - ENDDO -!$OMP END DO NOWAIT - - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - dv(ijb:ije,l)=0 - ENDDO -!$OMP END DO NOWAIT - - !----------------------------------------------------------------------- - ! Calcul de la dissipation: - ! ------------------------- - - ! Calcul de la partie grad ( div ) : - ! ------------------------------------- - - - - IF(lstardis) THEN - ! IF (.FALSE.) THEN - CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy ) - ELSE - ! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy ) - ENDIF - -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('gdx',gdx) - call WriteField_v('gdy',gdy) -END IF - - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - if (pole_nord) then - DO ij = 1, iip1 - gdx( ij ,l) = 0. - ENDDO - endif - - if (pole_sud) then - DO ij = 1, iip1 - gdx(ij+ip1jm,l) = 0. - ENDDO - endif - - if (pole_nord) ijb=ij_begin+iip1 - DO ij = ijb,ije - du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) - ENDDO - - if (pole_nord) ijb=ij_begin - DO ij = ijb,ije - dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) - ENDDO - - ENDDO -!$OMP END DO NOWAIT - ! calcul de la partie n X grad ( rot ): - ! --------------------------------------- - - IF(lstardis) THEN - ! IF (.FALSE.) THEN - CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry ) - ELSE - ! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry ) - ENDIF - -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('grx',grx) - call WriteField_v('gry',gry) -END IF - - - ijb=ij_begin - ije=ij_end - if (pole_sud) ije=ij_end-iip1 - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l=1,llm - - if (pole_nord) then - DO ij = 1, iip1 - grx(ij,l) = 0. - ENDDO - endif - - if (pole_nord) ijb=ij_begin+iip1 - DO ij = ijb,ije - du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) - ENDDO - - if (pole_nord) ijb=ij_begin - DO ij = ijb, ije - dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) - ENDDO - - ENDDO -!$OMP END DO NOWAIT - - ! calcul de la partie div ( grad ): - ! ----------------------------------- - - - IF(lstardis) THEN - ! IF (.FALSE.) THEN - - ijb=ij_begin - ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1, llm - DO ij = ijb, ije - deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) - ENDDO - ENDDO -!$OMP END DO NOWAIT - CALL divgrad2_loc( llm,teta, deltapres ,niterh, gdx ) - ELSE - ! CALL divgrad_p ( llm,teta, niterh, gdx ) - ENDIF - -IF (CPPKEY_DEBUGIO) THEN - call WriteField_u('gdx',gdx) -END IF - - - ijb=ij_begin - ije=ij_end - -!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) - DO l = 1,llm - DO ij = ijb,ije - dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) - ENDDO - ENDDO -!$OMP END DO NOWAIT - - RETURN -END SUBROUTINE dissip_loc Index: LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90 (revision 5268) @@ -0,0 +1,235 @@ +! +! $Id: $ +! +SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh ) + ! + USE parallel_lmdz + USE write_field_loc + USE dissip_mod, ONLY: dissip_allocate + USE comconst_mod, ONLY: dtdiss + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO + IMPLICIT NONE + + + ! .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... + ! ( 10/01/98 ) + + !======================================================================= + ! + ! Auteur: P. Le Van + ! ------- + ! + ! Objet: + ! ------ + ! + ! Dissipation horizontale + ! + !======================================================================= + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + include "dimensions.h" + include "paramet.h" + include "comgeom.h" + include "comdissnew.h" + include "comdissipn.h" + + ! Arguments: + ! ---------- + + REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind + REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind + REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature + REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure + ! ! tendencies (.../s) on covariant winds and potential temperature + REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) + REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) + REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm) + + ! Local: + ! ------ + + REAL :: gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm) + REAL :: grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm) + REAL :: te1dt(llm),te2dt(llm),te3dt(llm) + REAL :: deltapres(ijb_u:ije_u,llm) + + INTEGER :: l,ij + + REAL :: SSUM + integer :: ijb,ije + + LOGICAl,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + IF (first) THEN + CALL dissip_allocate + first=.FALSE. + ENDIF + !----------------------------------------------------------------------- + ! initialisations: + ! ---------------- + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO +!$OMP END DO NOWAIT + ! CALL initial0( ijp1llm, du ) + ! CALL initial0( ijmllm , dv ) + ! CALL initial0( ijp1llm, dh ) + + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du(ijb:ije,l)=0 + dh(ijb:ije,l)=0 + ENDDO +!$OMP END DO NOWAIT + + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dv(ijb:ije,l)=0 + ENDDO +!$OMP END DO NOWAIT + + !----------------------------------------------------------------------- + ! Calcul de la dissipation: + ! ------------------------- + + ! Calcul de la partie grad ( div ) : + ! ------------------------------------- + + + + IF(lstardis) THEN + ! IF (.FALSE.) THEN + CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE + ! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('gdx',gdx) + call WriteField_v('gdy',gdy) +END IF + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + if (pole_nord) then + DO ij = 1, iip1 + gdx( ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + gdx(ij+ip1jm,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb,ije + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO +!$OMP END DO NOWAIT + ! calcul de la partie n X grad ( rot ): + ! --------------------------------------- + + IF(lstardis) THEN + ! IF (.FALSE.) THEN + CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE + ! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('grx',grx) + call WriteField_v('gry',gry) +END IF + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + if (pole_nord) then + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb, ije + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + + ENDDO +!$OMP END DO NOWAIT + + ! calcul de la partie div ( grad ): + ! ----------------------------------- + + + IF(lstardis) THEN + ! IF (.FALSE.) THEN + + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO +!$OMP END DO NOWAIT + CALL divgrad2_loc( llm,teta, deltapres ,niterh, gdx ) + ELSE + ! CALL divgrad_p ( llm,teta, niterh, gdx ) + ENDIF + +IF (CPPKEY_DEBUGIO) THEN + call WriteField_u('gdx',gdx) +END IF + + + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = ijb,ije + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN +END SUBROUTINE dissip_loc Index: LMDZ6/trunk/libf/dyn3dmem/dissip_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dissip_mod.F90 (revision 5267) +++ (revision ) @@ -1,40 +1,0 @@ -MODULE dissip_mod - - - -CONTAINS - - SUBROUTINE dissip_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - USE gradiv2_mod, ONLY : gradiv2_allocate - USE nxgraro2_mod, ONLY : nxgraro2_allocate - USE divgrad2_mod, ONLY : divgrad2_allocate - IMPLICIT NONE - - CALL gradiv2_allocate - CALL nxgraro2_allocate - CALL divgrad2_allocate - - - END SUBROUTINE dissip_allocate - - SUBROUTINE dissip_switch_dissip(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - USE gradiv2_mod,ONLY : gradiv2_switch_dissip - USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip - USE divgrad2_mod,ONLY : divgrad2_switch_dissip - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL gradiv2_switch_dissip(dist) - CALL nxgraro2_switch_dissip(dist) - CALL divgrad2_switch_dissip(dist) - - END SUBROUTINE dissip_switch_dissip - -END MODULE dissip_mod Index: LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90 (revision 5268) @@ -0,0 +1,40 @@ +MODULE dissip_mod + + + +CONTAINS + + SUBROUTINE dissip_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + USE gradiv2_mod, ONLY : gradiv2_allocate + USE nxgraro2_mod, ONLY : nxgraro2_allocate + USE divgrad2_mod, ONLY : divgrad2_allocate + IMPLICIT NONE + + CALL gradiv2_allocate + CALL nxgraro2_allocate + CALL divgrad2_allocate + + + END SUBROUTINE dissip_allocate + + SUBROUTINE dissip_switch_dissip(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + USE gradiv2_mod,ONLY : gradiv2_switch_dissip + USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip + USE divgrad2_mod,ONLY : divgrad2_switch_dissip + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL gradiv2_switch_dissip(dist) + CALL nxgraro2_switch_dissip(dist) + CALL divgrad2_switch_dissip(dist) + + END SUBROUTINE dissip_switch_dissip + +END MODULE dissip_mod Index: LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.F90 (revision 5267) +++ (revision ) @@ -1,33 +1,0 @@ -MODULE divgrad2_mod - - REAL,POINTER,SAVE :: divgra( :,: ) - -CONTAINS - - SUBROUTINE divgrad2_allocate - USE bands - USE allocate_field_mod - USE parallel_lmdz - USE dimensions_mod - IMPLICIT NONE - TYPE(distrib),POINTER :: d - d=>distrib_dissip - - CALL allocate_u(divgra,llm,d) - - - END SUBROUTINE divgrad2_allocate - - SUBROUTINE divgrad2_switch_dissip(dist) - USE allocate_field_mod - USE bands - USE parallel_lmdz - IMPLICIT NONE - TYPE(distrib),INTENT(IN) :: dist - - CALL switch_u(divgra,distrib_dissip,dist) - - - END SUBROUTINE divgrad2_switch_dissip - -END MODULE divgrad2_mod Index: LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90 (revision 5268) +++ LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90 (revision 5268) @@ -0,0 +1,33 @@ +MODULE divgrad2_mod + + REAL,POINTER,SAVE :: divgra( :,: ) + +CONTAINS + + SUBROUTINE divgrad2_allocate + USE bands + USE allocate_field_mod + USE parallel_lmdz + USE dimensions_mod + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(divgra,llm,d) + + + END SUBROUTINE divgrad2_allocate + + SUBROUTINE divgrad2_switch_dissip(dist) + USE allocate_field_mod + USE bands + USE parallel_lmdz + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(divgra,distrib_dissip,dist) + + + END SUBROUTINE divgrad2_switch_dissip + +END MODULE divgrad2_mod Index: LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90 =================================================================== --- LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90 (revision 5267) +++ (revision ) @@ -1,308 +1,0 @@ -SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time) -! -!------------------------------------------------------------------------------- -! Authors: P. Le Van , L.Fairhead -!------------------------------------------------------------------------------- -! Purpose: Initial state reading. -!------------------------------------------------------------------------------- - USE parallel_lmdz - USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, & - new2oldH2O, newHNO3, oldHNO3 - USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx - USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, & - NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE, NF90_NoErr - USE control_mod, ONLY: planet_type - USE assert_eq_m, ONLY: assert_eq - USE comvert_mod, ONLY: pa,preff - USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad - USE logic_mod, ONLY: fxyhypb, ysinus - USE serre_mod, ONLY: clon, clat, grossismx, grossismy - USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time - USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 - USE IOIPSL, ONLY: getin - USE iso_params_mod ! tnat_* and alpha_ideal_* - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS - - IMPLICIT NONE - include "dimensions.h" - include "paramet.h" - include "comgeom.h" - include "description.h" - include "iniprint.h" -!=============================================================================== -! Arguments: - CHARACTER(LEN=*), INTENT(IN) :: fichnom !--- FILE NAME - REAL, INTENT(OUT) :: vcov(ijb_v:ije_v,llm) !--- V COVARIANT WIND - REAL, INTENT(OUT) :: ucov(ijb_u:ije_u,llm) !--- U COVARIANT WIND - REAL, INTENT(OUT) :: teta(ijb_u:ije_u,llm) !--- POTENTIAL TEMP. - REAL, INTENT(OUT) :: q(ijb_u:ije_u,llm,nqtot)!--- TRACERS - REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm) !--- MASS PER CELL - REAL, INTENT(OUT) :: ps(ijb_u:ije_u) !--- GROUND PRESSURE - REAL, INTENT(OUT) :: phis(ijb_u:ije_u) !--- GEOPOTENTIAL -!=============================================================================== -! Local variables: - CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar - INTEGER, PARAMETER :: length=100 - INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix - REAL :: time,tab_cntrl(length) !--- RUN PARAMS TABLE - REAL :: tnat, alpha_ideal - REAL, ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:), ps_glo(:) - REAL, ALLOCATABLE :: ucov_glo(:,:), q_glo(:,:), phis_glo(:) - REAL, ALLOCATABLE :: teta_glo(:,:) - LOGICAL :: lSkip, ll, ltnat1 -!------------------------------------------------------------------------------- - modname="dynetat0_loc" - -!--- Initial state file opening - var=fichnom - CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var) - CALL get_var1("controle",tab_cntrl) - -!!! AS: idecal is a hack to be able to read planeto starts... -!!! .... while keeping everything OK for LMDZ EARTH - IF(planet_type=="generic") THEN - CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname) - idecal = 4 - annee_ref = 2000 - ELSE - CALL msg('NOTE NOTE NOTE : Earth-like start files', modname) - idecal = 5 - annee_ref = tab_cntrl(5) - END IF - im = tab_cntrl(1) - jm = tab_cntrl(2) - lllm = tab_cntrl(3) - day_ref = tab_cntrl(4) - rad = tab_cntrl(idecal+1) - omeg = tab_cntrl(idecal+2) - g = tab_cntrl(idecal+3) - cpp = tab_cntrl(idecal+4) - kappa = tab_cntrl(idecal+5) - daysec = tab_cntrl(idecal+6) - dtvr = tab_cntrl(idecal+7) - etot0 = tab_cntrl(idecal+8) - ptot0 = tab_cntrl(idecal+9) - ztot0 = tab_cntrl(idecal+10) - stot0 = tab_cntrl(idecal+11) - ang0 = tab_cntrl(idecal+12) - pa = tab_cntrl(idecal+13) - preff = tab_cntrl(idecal+14) -! - clon = tab_cntrl(idecal+15) - clat = tab_cntrl(idecal+16) - grossismx = tab_cntrl(idecal+17) - grossismy = tab_cntrl(idecal+18) -! - IF ( tab_cntrl(idecal+19)==1. ) THEN - fxyhypb = .TRUE. -! dzoomx = tab_cntrl(25) -! dzoomy = tab_cntrl(26) -! taux = tab_cntrl(28) -! tauy = tab_cntrl(29) - ELSE - fxyhypb = .FALSE. - ysinus = tab_cntrl(idecal+22)==1. - END IF - - day_ini = tab_cntrl(30) - itau_dyn = tab_cntrl(31) - start_time = tab_cntrl(32) - -!------------------------------------------------------------------------------- - CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname) - CALL check_dim(im,iim,'im','im') - CALL check_dim(jm,jjm,'jm','jm') - CALL check_dim(lllm,llm,'lm','lllm') - CALL get_var1("rlonu",rlonu) - CALL get_var1("rlatu",rlatu) - CALL get_var1("rlonv",rlonv) - CALL get_var1("rlatv",rlatv) - CALL get_var1("cu" ,cu) - CALL get_var1("cv" ,cv) - CALL get_var1("aire",aire) - - var="temps" - IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN - CALL msg('missing field ; trying with