Index: codes/icosagcm/trunk/src/base/abort.F90
===================================================================
--- codes/icosagcm/trunk/src/base/abort.F90	(revision 926)
+++ codes/icosagcm/trunk/src/base/abort.F90	(revision 953)
@@ -17,3 +17,13 @@
     !$omp end single
   end subroutine
+
+  !!!Abort execution when openacc is on
+  subroutine abort_acc( message )
+    use mpi_mod
+    implicit none
+    character(len=*), optional, intent(in) :: message  
+#ifdef _OPENACC
+    call dynamico_abort( "Not tested with OpenACC ! " // message )
+#endif
+  end subroutine
 end module
Index: codes/icosagcm/trunk/src/base/field.f90
===================================================================
--- codes/icosagcm/trunk/src/base/field.f90	(revision 926)
+++ codes/icosagcm/trunk/src/base/field.f90	(revision 953)
@@ -13,7 +13,7 @@
   TYPE t_field
     CHARACTER(30)      :: name
-    REAL(rstd),POINTER :: rval2d(:)
-    REAL(rstd),POINTER :: rval3d(:,:)
-    REAL(rstd),POINTER :: rval4d(:,:,:)
+    REAL(rstd),POINTER :: rval2d(:) => null()
+    REAL(rstd),POINTER :: rval3d(:,:) => null()
+    REAL(rstd),POINTER :: rval4d(:,:,:) => null()
 
     INTEGER,POINTER :: ival2d(:)
@@ -30,4 +30,6 @@
     INTEGER :: dim3
     INTEGER :: dim4
+    
+    LOGICAL :: ondevice !< flag if field is allocated on device as well
   END TYPE t_field   
 
@@ -48,5 +50,5 @@
 CONTAINS
 
-  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name)
+  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name,ondevice)
   USE domain_mod
   USE omp_para
@@ -56,13 +58,16 @@
     INTEGER,OPTIONAL :: dim1,dim2
     CHARACTER(*), OPTIONAL :: name
+    LOGICAL, INTENT(IN), OPTIONAL :: ondevice 
 !$OMP BARRIER
 !$OMP MASTER
-    ALLOCATE(field(ndomain))
+    ALLOCATE(field(ndomain))    
 !$OMP END MASTER
 !$OMP BARRIER
-    CALL allocate_field_(field,field_type,data_type,dim1,dim2,name)
+
+    CALL allocate_field_(field,field_type,data_type,dim1,dim2,name,ondevice)
+    
   END SUBROUTINE allocate_field
 
-  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name)
+  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name, ondevice)
   USE domain_mod
   USE omp_para
@@ -73,4 +78,5 @@
     INTEGER,OPTIONAL :: dim1,dim2
     CHARACTER(*), OPTIONAL :: name
+    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
     INTEGER :: i
 !$OMP BARRIER
@@ -80,9 +86,9 @@
 !$OMP BARRIER
     DO i=1,nfield
-       CALL allocate_field_(field(:,i),field_type,data_type,dim1,dim2,name)
+       CALL allocate_field_(field(:,i),field_type,data_type,dim1,dim2,name,ondevice)
     END DO
   END SUBROUTINE allocate_fields
 
-  SUBROUTINE allocate_field_(field,field_type,data_type,dim1,dim2,name)
+  SUBROUTINE allocate_field_(field,field_type,data_type,dim1,dim2,name,ondevice)
   USE domain_mod
   USE omp_para
@@ -93,4 +99,5 @@
     INTEGER,OPTIONAL :: dim1,dim2
     CHARACTER(*), OPTIONAL :: name
+    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
     INTEGER :: ind
     INTEGER :: ii_size,jj_size
@@ -119,5 +126,5 @@
       field(ind)%data_type=data_type
       field(ind)%field_type=field_type
-    
+
       IF (field_type==field_T) THEN 
         jj_size=domain(ind)%jjm
@@ -131,17 +138,25 @@
         
       IF (field(ind)%ndim==4) THEN
-        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
-        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
-        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
+         IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
+         IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
+         IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
+
       ELSE IF (field(ind)%ndim==3) THEN
-        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
-        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
-        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
+         IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
+         IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
+         IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
+
       ELSE IF (field(ind)%ndim==2) THEN
-        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
-        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
-        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
-      ENDIF
-      
+         IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
+         IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
+         IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
+
+      ENDIF
+
+      field(ind)%ondevice = .FALSE.
+      IF (PRESENT(ondevice)) THEN
+         IF (ondevice) CALL create_device_field(field(ind))
+      END IF
+   
    ENDDO
 !$OMP BARRIER
@@ -160,5 +175,5 @@
     INTEGER :: ii_size,jj_size
 
-    ALLOCATE(field(ndomain_glo))    
+    ALLOCATE(field(ndomain_glo)) 
 
     DO ind=1,ndomain_glo
@@ -184,4 +199,6 @@
       field(ind)%field_type=field_type
     
+      field(ind)%ondevice = .FALSE.
+
       IF (field_type==field_T) THEN 
         jj_size=domain_glo(ind)%jjm
@@ -251,23 +268,86 @@
     INTEGER :: ind
     DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
-
-      data_type=field(ind)%data_type
-        
-      IF (field(ind)%ndim==4) THEN
-        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
-        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
-        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
-      ELSE IF (field(ind)%ndim==3) THEN
-        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
-        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
-        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
-      ELSE IF (field(ind)%ndim==2) THEN
-        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
-        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
-        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
-      ENDIF
-      
-   ENDDO
+       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
+
+       data_type=field(ind)%data_type
+
+       IF (field(ind)%ndim==4) THEN
+          IF (data_type==type_integer) THEN
+             DEALLOCATE(field(ind)%ival4d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%ival4d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_real) THEN
+             DEALLOCATE(field(ind)%rval4d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%rval4d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_logical) THEN
+             DEALLOCATE(field(ind)%lval4d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%lval4d)
+                CONTINUE
+             END IF
+          END IF
+
+       ELSE IF (field(ind)%ndim==3) THEN
+          IF (data_type==type_integer) THEN
+             DEALLOCATE(field(ind)%ival3d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%ival3d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_real) THEN
+             DEALLOCATE(field(ind)%rval3d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%rval3d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_logical) THEN
+             DEALLOCATE(field(ind)%lval3d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%lval3d)
+                CONTINUE
+             END IF
+          END IF
+
+       ELSE IF (field(ind)%ndim==2) THEN
+          IF (data_type==type_integer) THEN
+             DEALLOCATE(field(ind)%ival2d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%ival2d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_real) THEN
+             DEALLOCATE(field(ind)%rval2d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%rval2d)
+                CONTINUE
+             END IF
+          END IF
+
+          IF (data_type==type_logical) THEN
+             DEALLOCATE(field(ind)%lval2d)
+             IF (field(ind)%ondevice) THEN
+                !$acc exit data delete(field(ind)%lval2d)
+                CONTINUE
+             END IF
+          END IF
+
+       ENDIF
+
+    ENDDO
   END SUBROUTINE deallocate_field_
 
@@ -460,3 +540,182 @@
   END SUBROUTINE  getval_l4d    
 
+
+  SUBROUTINE update_device_field(field)
+  USE domain_mod
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field) :: field(:)
+    INTEGER :: ind
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
+
+      IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
+
+      IF (field(ind)%ndim==4) THEN
+         IF (field(ind)%data_type==type_integer) THEN
+            !$acc update device(field(ind)%ival4d(:,:,:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_real) THEN
+            !$acc update device(field(ind)%rval4d(:,:,:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_logical) THEN
+            !$acc update device(field(ind)%lval4d(:,:,:))
+            CONTINUE
+         END IF
+
+      ELSE IF (field(ind)%ndim==3) THEN
+         IF (field(ind)%data_type==type_integer) THEN
+            !$acc update device(field(ind)%ival3d(:,:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_real) THEN
+            !$acc update device(field(ind)%rval3d(:,:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_logical) THEN
+            !$acc update device(field(ind)%lval3d(:,:))
+            CONTINUE
+         END IF
+
+      ELSE IF (field(ind)%ndim==2) THEN
+         IF (field(ind)%data_type==type_integer) THEN
+            !$acc update device(field(ind)%ival2d(:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_real) THEN
+            !$acc update device(field(ind)%rval2d(:))
+            CONTINUE
+         END IF
+
+         IF (field(ind)%data_type==type_logical) THEN
+            !$acc update device(field(ind)%lval2d(:))
+            CONTINUE
+         END IF
+      ENDIF
+   ENDDO
+   !$OMP BARRIER
+ END SUBROUTINE update_device_field
+ 
+  SUBROUTINE update_host_field(field)
+  USE domain_mod
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field) :: field(:)
+    INTEGER :: ind
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
+
+      IF (field(ind)%ondevice) THEN
+        
+         IF (field(ind)%ndim==4) THEN
+            IF (field(ind)%data_type==type_integer) THEN
+               !$acc update host(field(ind)%ival4d(:,:,:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_real) THEN
+               !$acc update host(field(ind)%rval4d(:,:,:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_logical) THEN
+               !$acc update host(field(ind)%lval4d(:,:,:)) wait
+               CONTINUE
+            END IF
+         
+         ELSE IF (field(ind)%ndim==3) THEN
+            IF (field(ind)%data_type==type_integer) THEN
+               !$acc update host(field(ind)%ival3d(:,:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_real) THEN
+               !$acc update host(field(ind)%rval3d(:,:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_logical) THEN
+               !$acc update host(field(ind)%lval3d(:,:)) wait
+               CONTINUE
+            END IF
+
+         ELSE IF (field(ind)%ndim==2) THEN
+            IF (field(ind)%data_type==type_integer) THEN
+               !$acc update host(field(ind)%ival2d(:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_real) THEN
+               !$acc update host(field(ind)%rval2d(:)) wait
+               CONTINUE
+            END IF
+
+            IF (field(ind)%data_type==type_logical) THEN
+               !$acc update host(field(ind)%lval2d(:)) wait
+               CONTINUE
+            END IF
+         ENDIF
+      END IF
+   ENDDO
+   !$OMP BARRIER
+ END SUBROUTINE update_host_field
+
+ SUBROUTINE create_device_field(field)
+    TYPE(t_field) :: field
+
+    IF (field%ondevice) THEN
+       PRINT *, "Field is already on device !"
+       STOP 1
+    END IF
+    IF (field%ndim==4) THEN
+       IF (field%data_type==type_integer) THEN
+          !$acc enter data create(field%ival4d(:,:,:))
+       END IF
+
+       IF (field%data_type==type_real) THEN
+          !$acc enter data create(field%rval4d(:,:,:))
+       END IF
+
+       IF (field%data_type==type_logical) THEN
+          !$acc enter data create(field%lval4d(:,:,:))
+       END IF
+
+    ELSE IF (field%ndim==3) THEN
+       IF (field%data_type==type_integer) THEN
+          !$acc enter data create(field%ival3d(:,:))
+       END IF
+
+       IF (field%data_type==type_real) THEN
+          !$acc enter data create(field%rval3d(:,:))
+       END IF
+
+       IF (field%data_type==type_logical) THEN
+          !$acc enter data create(field%lval3d(:,:))
+       END IF
+
+    ELSE IF (field%ndim==2) THEN
+       IF (field%data_type==type_integer) THEN
+          !$acc enter data create(field%ival2d(:))
+       END IF
+
+       IF (field%data_type==type_real) THEN
+          !$acc enter data create(field%rval2d(:))
+       END IF
+
+       IF (field%data_type==type_logical) THEN
+          !$acc enter data create(field%lval2d(:))
+       END IF
+    ENDIF
+    field%ondevice = .TRUE.
+  END SUBROUTINE create_device_field
+ 
 END MODULE field_mod   
Index: codes/icosagcm/trunk/src/diagnostics/check_conserve.f90
===================================================================
--- codes/icosagcm/trunk/src/diagnostics/check_conserve.f90	(revision 926)
+++ codes/icosagcm/trunk/src/diagnostics/check_conserve.f90	(revision 953)
@@ -1,4 +1,5 @@
 MODULE check_conserve_mod
   USE icosa 
+  USE abort_mod
   IMPLICIT NONE 
 
@@ -28,4 +29,5 @@
     USE getin_mod
     USE omp_para, ONLY : is_master
+    USE abort_mod
     CHARACTER(LEN=255) :: check_type_str
     CALL allocate_field(f_pk,field_t,type_real,llm)
@@ -47,4 +49,8 @@
        STOP
     END SELECT
+
+    IF (check_type /= check_basic) THEN
+       CALL abort_acc("check_conservation /= 'basic'")
+    END IF
   END SUBROUTINE init_check_conserve
 
@@ -179,5 +185,5 @@
     
     IF(check_type == check_detailed) THEN
-
+       CALL abort_acc("!check_detailed")
        CALL transfert_request(f_ue,req_e1_vect)
        CALL pression(f_ps,f_p)
Index: codes/icosagcm/trunk/src/diagnostics/diagflux.F90
===================================================================
--- codes/icosagcm/trunk/src/diagnostics/diagflux.F90	(revision 926)
+++ codes/icosagcm/trunk/src/diagnostics/diagflux.F90	(revision 953)
@@ -21,7 +21,12 @@
   SUBROUTINE init_diagflux
     USE getin_mod
+    USE abort_mod
     INTEGER :: ll
     diagflux_on = .FALSE.
     CALL getin("diagflux", diagflux_on)
+    IF (diagflux_on) THEN
+       CALL abort_acc("diagflux /= .FALSE.")
+    END IF
+
     ll = MERGE(llm,1,diagflux_on)
     CALL allocate_field(f_masst,         field_t,type_real,ll,       name="masst")
Index: codes/icosagcm/trunk/src/diagnostics/observable.f90
===================================================================
--- codes/icosagcm/trunk/src/diagnostics/observable.f90	(revision 926)
+++ codes/icosagcm/trunk/src/diagnostics/observable.f90	(revision 953)
@@ -30,5 +30,5 @@
     CALL allocate_field(f_buf_s,   field_t,type_real, name="buf_s")
 
-    CALL allocate_field(f_theta, field_t,type_real,llm,nqdyn,  name='theta') ! potential temperature
+    CALL allocate_field(f_theta, field_t,type_real,llm,nqdyn,  name='theta', ondevice=.TRUE.) ! potential temperature
     CALL allocate_field(f_pmid,  field_t,type_real,llm,  name='pmid')       ! mid layer pressure
   END SUBROUTINE init_observable
@@ -56,4 +56,5 @@
 
     CALL transfert_request(f_ps,req_i1)
+    CALL update_host_field(f_ps)
     
     IF(init) THEN
@@ -109,5 +110,5 @@
     
     CALL progonostic_vel_to_horiz(f_geopot, f_ps, f_mass, f_u, f_W, f_buf_uh, f_buf_i)
-    CALL transfert_request(f_buf_uh,req_e1_vect) 
+    CALL transfert_request(f_buf_uh,req_e1_vect)
     CALL un2ulonlat(f_buf_uh, f_buf_ulon, f_buf_ulat)
     IF(init) THEN
Index: codes/icosagcm/trunk/src/dissip/dissip_gcm.F90
===================================================================
--- codes/icosagcm/trunk/src/dissip/dissip_gcm.F90	(revision 953)
+++ codes/icosagcm/trunk/src/dissip/dissip_gcm.F90	(revision 953)
@@ -0,0 +1,1068 @@
+MODULE dissip_gcm_mod
+  USE icosa
+  USE abort_mod
+  PRIVATE
+
+  TYPE(t_field),POINTER,SAVE :: f_due_diss1(:)
+  TYPE(t_field),POINTER,SAVE :: f_due_diss2(:)
+
+  TYPE(t_field),POINTER,SAVE :: f_dtheta_diss(:)
+  TYPE(t_field),POINTER,SAVE :: f_dtheta_rhodz_diss(:)
+  TYPE(t_message),SAVE :: req_due, req_dtheta 
+ 
+  INTEGER,SAVE :: nitergdiv=1
+!$OMP THREADPRIVATE(nitergdiv)
+  INTEGER,SAVE :: nitergrot=1
+!$OMP THREADPRIVATE(nitergrot)
+  INTEGER,SAVE :: niterdivgrad=1
+!$OMP THREADPRIVATE(niterdivgrad)
+
+  REAL,ALLOCATABLE,SAVE :: tau_graddiv(:)
+!$OMP THREADPRIVATE(tau_graddiv)
+  REAL,ALLOCATABLE,SAVE :: tau_gradrot(:)
+!$OMP THREADPRIVATE(tau_gradrot)
+  REAL,ALLOCATABLE,SAVE :: tau_divgrad(:)
+!$OMP THREADPRIVATE(tau_divgrad)
+  
+  REAL,SAVE :: cgraddiv
+!$OMP THREADPRIVATE(cgraddiv)
+  REAL,SAVE :: cgradrot
+!$OMP THREADPRIVATE(cgradrot)
+  REAL,SAVE :: cdivgrad
+!$OMP THREADPRIVATE(cdivgrad)
+
+  INTEGER, SAVE :: rayleigh_friction_type, rayleigh_shear
+!$OMP THREADPRIVATE(rayleigh_friction_type)
+!$OMP THREADPRIVATE(rayleigh_shear)
+  REAL, SAVE    :: rayleigh_tau, rayleigh_limlat
+!$OMP THREADPRIVATE(rayleigh_tau)
+!$OMP THREADPRIVATE(rayleigh_limlat)
+  
+  REAL,SAVE    :: dtdissip
+!$OMP THREADPRIVATE(dtdissip)
+ 
+  PUBLIC init_dissip, dissip
+CONTAINS
+
+  SUBROUTINE allocate_dissip
+  USE icosa
+  IMPLICIT NONE  
+    CALL allocate_field(f_due_diss1,field_u,type_real,llm,ondevice=.TRUE.)
+    CALL allocate_field(f_due_diss2,field_u,type_real,llm,ondevice=.TRUE.)
+    CALL allocate_field(f_dtheta_diss,field_t,type_real,llm)
+    CALL allocate_field(f_dtheta_rhodz_diss,field_t,type_real,llm,ondevice=.TRUE.)
+    ALLOCATE(tau_graddiv(llm))
+    ALLOCATE(tau_gradrot(llm))    
+    ALLOCATE(tau_divgrad(llm))
+    !$acc enter data create(tau_graddiv(:),tau_gradrot(:),tau_divgrad(:)) async
+  END SUBROUTINE allocate_dissip
+ 
+  SUBROUTINE init_dissip
+  USE icosa
+  USE disvert_mod
+  USE mpi_mod
+  USE mpipara
+  USE transfert_mod
+  USE time_mod
+  USE transfert_omp_mod
+  USE omp_para
+  USE abort_mod
+  IMPLICIT NONE
+  
+  TYPE(t_field),POINTER,SAVE  :: f_u(:)
+  TYPE(t_field),POINTER,SAVE  :: f_du(:)
+  REAL(rstd),POINTER     :: u(:)
+  REAL(rstd),POINTER     :: du(:)
+  TYPE(t_field),POINTER,SAVE  :: f_theta(:)
+  TYPE(t_field),POINTER ,SAVE :: f_dtheta(:)
+  REAL(rstd),POINTER    :: theta(:)
+  REAL(rstd),POINTER    :: dtheta(:)
+  REAL(rstd)            :: dumax,dumax1
+  REAL(rstd)            :: dthetamax,dthetamax1
+  REAL(rstd)            :: r
+  REAL(rstd)            :: tau
+  REAL(rstd)            :: zz, zvert, fact
+  INTEGER               :: l
+  CHARACTER(len=255)    :: rayleigh_friction_key
+  REAL(rstd)            :: mintau
+  
+  ! New variables added for dissipation vertical profile (SF, 19/09/18)
+  INTEGER    :: vert_prof_dissip
+  REAL(rstd) :: dissip_factz,dissip_deltaz,dissip_zref,pseudoz
+                        
+  INTEGER :: i,j,ij,ind,it,iter,M
+
+   rayleigh_friction_key='none'
+   CALL getin("rayleigh_friction_type",rayleigh_friction_key)
+   SELECT CASE(TRIM(rayleigh_friction_key))
+   CASE('none')
+      rayleigh_friction_type=0
+      IF (is_master) PRINT *, 'No Rayleigh friction'
+   CASE('dcmip2_schaer_noshear')
+      CALL abort_acc("rayleigh_friction_type /= 'none'")
+      rayleigh_friction_type=1
+      rayleigh_shear=0
+      IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain without shear DCMIP2.1'
+   CASE('dcmip2_schaer_shear')
+      CALL abort_acc("rayleigh_friction_type /= 'none'")
+      rayleigh_shear=1
+      rayleigh_friction_type=2
+      IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain with shear DCMIP2.2'
+   CASE('giant_liu_schneider') 
+      CALL abort_acc("rayleigh_friction_type /= 'none'")
+      rayleigh_friction_type=99
+      IF (is_master) PRINT *, 'Rayleigh friction : giant planets Liu Schneider 2010'
+   CASE DEFAULT
+      IF (is_master) PRINT *, 'Bad selector : rayleigh_friction_type =', TRIM(rayleigh_friction_key), &
+        ' in dissip_gcm.f90/init_dissip'
+      STOP
+   END SELECT
+
+   IF(rayleigh_friction_type>0) THEN
+      rayleigh_tau=0.
+      CALL getin("rayleigh_friction_tau",rayleigh_tau)
+      rayleigh_tau = rayleigh_tau / scale_factor
+      IF(rayleigh_tau<=0) THEN
+         IF (is_master) PRINT *, 'Forbidden : negative value for rayleigh_friction_tau =',rayleigh_tau
+         STOP
+      END IF
+      IF(rayleigh_friction_type == 99) THEN
+         rayleigh_limlat=0.
+         CALL getin("rayleigh_limlat",rayleigh_limlat)
+         rayleigh_limlat = rayleigh_limlat*3.14159/180.
+      ENDIF
+   END IF
+
+    CALL allocate_dissip
+    CALL allocate_field(f_u,field_u,type_real,ondevice=.TRUE.)
+    CALL allocate_field(f_du,field_u,type_real,ondevice=.TRUE.)
+    CALL allocate_field(f_theta,field_t,type_real,ondevice=.TRUE.)
+    CALL allocate_field(f_dtheta,field_t,type_real,ondevice=.TRUE.)
+    
+    CALL init_message(f_due_diss1,req_e1_vect,req_due)
+    CALL init_message(f_dtheta_diss,req_i1,req_dtheta)
+
+    tau_graddiv(:)=5000
+    CALL getin("tau_graddiv",tau)
+    tau_graddiv(:)=tau/scale_factor
+
+    CALL getin("nitergdiv",nitergdiv)
+    
+    tau_gradrot(:)=5000
+    CALL getin("tau_gradrot",tau)
+    tau_gradrot(:)=tau/scale_factor
+
+    CALL getin("nitergrot",nitergrot)
+    
+
+    tau_divgrad(:)=5000
+    CALL getin("tau_divgrad",tau)
+    tau_divgrad(:)=tau/scale_factor
+
+    CALL getin("niterdivgrad",niterdivgrad)
+
+
+    cgraddiv=-1
+    cdivgrad=-1
+    cgradrot=-1
+
+!$OMP BARRIER
+!$OMP MASTER
+    DO ind=1,ndomain
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      u=f_u(ind)
+
+! set random seed to get reproductibility when using a different number of process
+      CALL RANDOM_SEED(size=M)
+      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
+
+      ! This cannot be ported on GPU due to compiler limitations
+      DO j=jj_begin,jj_end
+        DO i=ii_begin,ii_end
+          ij=(j-1)*iim+i   
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_right)=r-0.5
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_lup)=r-0.5
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_ldown)=r-0.5
+        ENDDO
+      ENDDO        
+    ENDDO
+!$OMP END MASTER  
+!$OMP BARRIER
+
+    DO it=1,20
+      
+      dumax=0
+      DO iter=1,nitergdiv
+        CALL update_device_field(f_u)
+        CALL transfert_request(f_u,req_e1_vect)
+         
+        DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+          CALL swap_dimensions(ind)
+          CALL swap_geometry(ind)
+          u=f_u(ind)
+          du=f_du(ind)
+          CALL compute_gradiv_inplace(u,1,1)
+          ! This should be ported on GPU but we are running into compiler issues...
+          !$acc update host(u(:)) wait
+          du=u
+        ENDDO
+      ENDDO
+
+      CALL update_device_field(f_du)
+      CALL transfert_request(f_du,req_e1_vect)
+      CALL update_host_field(f_du)
+
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        du=f_du(ind)
+         
+        ! Not ported on GPU because all the other kernels cannot be ported
+        DO j=jj_begin,jj_end
+          DO i=ii_begin,ii_end
+            ij=(j-1)*iim+i   
+            if (le(ij+u_right)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_right)))
+            if (le(ij+u_lup)>1e-100)   dumax=MAX(dumax,ABS(du(ij+u_lup)))
+            if (le(ij+u_ldown)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_ldown)))
+          ENDDO
+        ENDDO
+      ENDDO
+
+      IF (using_mpi) THEN 
+        CALL reduce_max_omp(dumax,dumax1)
+!$OMP MASTER        
+        CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
+!$OMP END MASTER     
+        CALL bcast_omp(dumax)  
+      ELSE
+        CALL allreduce_max_omp(dumax,dumax1)
+        dumax=dumax1
+      ENDIF  
+			
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        u=f_u(ind)
+        du=f_du(ind)
+        ! This should be ported on GPU but we are running into compiler issues...
+        u=du/dumax
+      ENDDO
+      IF (is_master) PRINT *,"gradiv : it :",it ,": dumax",dumax
+
+    ENDDO 
+    IF (is_master) PRINT *,"gradiv : dumax",dumax
+    IF (is_master) PRINT *, 'mean T-cell edge size (km)', 1.45*radius/iim_glo/1000., &
+                              'effective T-cell half-edge size (km)', dumax**(-.5/nitergdiv)/1000
+    IF (is_master)  PRINT *, 'Max. time step assuming c=340 m/s and Courant number=3 (ARK2.3) :', &
+                               3./340.*dumax**(-.5/nitergdiv)
+
+    cgraddiv=dumax**(-1./nitergdiv)
+    IF (is_master) PRINT *,"cgraddiv : ",cgraddiv
+
+!$OMP BARRIER
+!$OMP MASTER
+    DO ind=1,ndomain
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      u=f_u(ind)
+
+! set random seed to get reproductibility when using a different number of process
+      CALL RANDOM_SEED(size=M)
+      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
+ 
+      ! This cannot be ported on GPU due to compiler limitations
+       DO j=jj_begin,jj_end
+        DO i=ii_begin,ii_end
+          ij=(j-1)*iim+i   
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_right)=r-0.5
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_lup)=r-0.5
+          CALL RANDOM_NUMBER(r)
+          u(ij+u_ldown)=r-0.5
+        ENDDO
+      ENDDO        
+    ENDDO
+!$OMP END MASTER  
+!$OMP BARRIER
+
+    DO it=1,20
+ 
+      dumax=0
+      DO iter=1,nitergrot
+        CALL update_device_field(f_u)
+        CALL transfert_request(f_u,req_e1_vect)
+        DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+          CALL swap_dimensions(ind)
+          CALL swap_geometry(ind)
+          u=f_u(ind)
+          du=f_du(ind)
+          CALL compute_gradrot_inplace(u,1,1)
+          ! This should be ported on GPU but we are running into compiler issues...
+          !$acc update host(u(:)) wait
+          du=u
+        ENDDO
+      ENDDO
+      
+      CALL update_device_field(f_du)
+      CALL transfert_request(f_du,req_e1_vect)
+      CALL update_host_field(f_du)
+      
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        du=f_du(ind)
+        
+        ! Not ported on GPU because all the other kernels cannot be ported
+        DO j=jj_begin,jj_end
+          DO i=ii_begin,ii_end
+            ij=(j-1)*iim+i   
+            if (le(ij+u_right)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_right)))
+            if (le(ij+u_lup)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_lup)))
+            if (le(ij+u_ldown)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_ldown)))
+          ENDDO
+        ENDDO
+      ENDDO
+
+      IF (using_mpi) THEN 
+        CALL reduce_max_omp(dumax,dumax1)
+!$OMP MASTER        
+        CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
+!$OMP END MASTER     
+        CALL bcast_omp(dumax)  
+      ELSE
+        CALL allreduce_max_omp(dumax,dumax1)
+        dumax=dumax1
+      ENDIF  
+
+      
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        u=f_u(ind)
+        du=f_du(ind)
+        ! This should be ported on GPU but we are running into compiler issues...
+        u=du/dumax
+      ENDDO
+      
+      IF (is_master) PRINT *,"gradrot : it :",it ,": dumax",dumax
+
+    ENDDO 
+    IF (is_master) PRINT *,"gradrot : dumax",dumax
+  
+    cgradrot=dumax**(-1./nitergrot) 
+    IF (is_master) PRINT *,"cgradrot : ",cgradrot
+   
+
+
+!$OMP BARRIER
+!$OMP MASTER
+    DO ind=1,ndomain
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      theta=f_theta(ind)
+
+! set random seed to get reproductibility when using a different number of process
+      CALL RANDOM_SEED(size=M)
+      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
+
+      ! This cannot be ported on GPU due to compiler limitations
+      DO j=jj_begin,jj_end
+        DO i=ii_begin,ii_end
+          ij=(j-1)*iim+i   
+          CALL RANDOM_NUMBER(r)
+          theta(ij)=r-0.5
+        ENDDO
+      ENDDO  
+    ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+
+    DO it=1,20
+
+      dthetamax=0
+      DO iter=1,niterdivgrad
+        CALL update_device_field(f_theta)
+        CALL transfert_request(f_theta,req_i1)
+        DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+          CALL swap_dimensions(ind)
+          CALL swap_geometry(ind)
+          theta=f_theta(ind)
+          dtheta=f_dtheta(ind)
+          CALL compute_divgrad_inplace(theta,1,1)
+          ! This should be ported on GPU but we are running into compiler issues...
+          !$acc update host(theta(:)) wait
+          dtheta=theta
+        ENDDO
+      ENDDO
+
+      CALL update_device_field(f_dtheta)
+      CALL transfert_request(f_dtheta,req_i1)
+      CALL update_host_field(f_dtheta)
+      
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        dtheta=f_dtheta(ind)
+        
+        ! Not ported on GPU because all the other kernels cannot be ported
+        DO j=jj_begin,jj_end
+          DO i=ii_begin,ii_end
+            ij=(j-1)*iim+i   
+            dthetamax=MAX(dthetamax,ABS(dtheta(ij)))
+          ENDDO
+        ENDDO
+      ENDDO
+
+      IF (using_mpi) THEN 
+        CALL reduce_max_omp(dthetamax ,dthetamax1)
+!$OMP MASTER        
+        CALL MPI_ALLREDUCE(dthetamax1,dthetamax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
+!$OMP END MASTER     
+        CALL bcast_omp(dthetamax)  
+      ELSE
+        CALL allreduce_max_omp(dthetamax,dthetamax1)
+        dumax=dumax1
+      ENDIF  
+      
+      IF (is_master) PRINT *,"divgrad : it :",it ,": dthetamax",dthetamax
+
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        theta=f_theta(ind)
+        dtheta=f_dtheta(ind)
+        ! This should be ported on GPU but we are running into compiler issues...
+        theta=dtheta/dthetamax
+      ENDDO
+    ENDDO 
+
+    IF (is_master) PRINT *,"divgrad : divgrad",dthetamax
+  
+    cdivgrad=dthetamax**(-1./niterdivgrad) 
+    IF (is_master) PRINT *,"cdivgrad : ",cdivgrad
+
+    ! Added CMIP5 dissipation vertical profile (SF, 19/09/18)
+    vert_prof_dissip = 1
+    CALL getin('vert_prof_dissip',vert_prof_dissip)
+    IF (vert_prof_dissip == 1) then
+       dissip_zref = 30.
+       dissip_deltaz = 10.
+       dissip_factz = 4.
+       CALL getin('dissip_factz',dissip_factz )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_zref',dissip_zref )
+       DO l=1,llm
+          pseudoz=8.*log(preff/presnivs(l))
+          zvert=1+ &
+               (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. &
+               *(dissip_factz-1.)
+          tau_graddiv(l) = tau_graddiv(l)/zvert
+          tau_gradrot(l) = tau_gradrot(l)/zvert
+          tau_divgrad(l) = tau_divgrad(l)/zvert
+       ENDDO
+    ELSE     
+       fact=2
+       DO l=1,llm
+          IF(ap_bp_present) THEN ! height-dependent dissipation
+             zz= 1. - preff/presnivs(l)
+          ELSE
+             zz = 0.
+          END IF
+          zvert=fact-(fact-1)/(1+zz*zz)
+          tau_graddiv(l) = tau_graddiv(l)/zvert
+          tau_gradrot(l) = tau_gradrot(l)/zvert
+          tau_divgrad(l) = tau_divgrad(l)/zvert
+       ENDDO
+    ENDIF
+
+    mintau=tau_graddiv(1)
+    DO l=1,llm
+      mintau=MIN(mintau,tau_graddiv(l))
+      mintau=MIN(mintau,tau_gradrot(l))
+      mintau=MIN(mintau,tau_divgrad(l))
+    ENDDO
+
+    IF(rayleigh_friction_type>0) mintau=MIN(mintau,rayleigh_tau)
+
+    IF(mintau>0) THEN
+       IF (itau_dissip==0) THEN
+         IF (is_master) PRINT *,"init_dissip: Automatic computation of itau_dissip..."
+         itau_dissip=INT(mintau/dt)
+       ENDIF
+    ELSE
+       IF (is_master) PRINT *,"init_dissip: No dissipation time set, setting itau_dissip to 1000000000"
+       itau_dissip=100000000
+    END IF
+    itau_dissip=MAX(1,itau_dissip)
+    dtdissip=itau_dissip*dt
+    IF (is_master) THEN
+      PRINT *,"init_dissip: rayleigh_tau",rayleigh_tau, "mintau ",mintau
+      PRINT *,"init_dissip: itau_dissip",itau_dissip," dtdissip ",dtdissip
+    ENDIF
+
+    !$acc update device(tau_graddiv(:),tau_gradrot(:),tau_divgrad(:)) async
+
+  END SUBROUTINE init_dissip 
+ 
+  
+  SUBROUTINE dissip(f_ps,f_mass,f_phis,f_geopot,f_theta_rhodz,f_ue, f_dtheta_rhodz,f_due)
+  USE icosa
+  USE theta2theta_rhodz_mod
+  USE pression_mod
+  USE exner_mod
+  USE geopotential_mod
+  USE trace
+  USE time_mod
+  USE omp_para
+  USE abort_mod
+  IMPLICIT NONE
+    TYPE(t_field),POINTER :: f_ps(:), f_mass(:), f_phis(:), f_geopot(:)
+    TYPE(t_field),POINTER :: f_theta_rhodz(:), f_dtheta_rhodz(:)
+    TYPE(t_field),POINTER :: f_ue(:), f_due(:)
+
+    REAL(rstd),POINTER         :: due(:,:)
+    REAL(rstd),POINTER         :: phi(:,:), ue(:,:)
+    REAL(rstd),POINTER         :: due_diss1(:,:)
+    REAL(rstd),POINTER         :: due_diss2(:,:)
+    REAL(rstd),POINTER         :: dtheta_rhodz(:,:,:)
+    REAL(rstd),POINTER         :: dtheta_rhodz_diss(:,:)
+
+    INTEGER :: ind, shear
+    INTEGER :: l,ij,nn
+
+!$OMP BARRIER
+    
+    CALL trace_start("dissip")
+    CALL gradiv(f_ue,f_due_diss1)
+    CALL gradrot(f_ue,f_due_diss2)
+
+    CALL divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz_diss)
+    
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      due=f_due(ind) 
+      due_diss1=f_due_diss1(ind)
+      due_diss2=f_due_diss2(ind)
+      dtheta_rhodz=f_dtheta_rhodz(ind)
+      dtheta_rhodz_diss=f_dtheta_rhodz_diss(ind)
+
+      !$acc parallel loop collapse(2) present(due(:,:), dtheta_rhodz(:,:,:), due_diss1(:,:), due_diss2(:,:), dtheta_rhodz_diss(:,:), tau_graddiv(:), tau_gradrot(:), tau_divgrad(:)) async
+      DO l=ll_begin,ll_end
+!DIR$ SIMD
+        DO ij=ij_begin,ij_end
+
+            due(ij+u_right,l) = -0.5*( due_diss1(ij+u_right,l)/tau_graddiv(l) + due_diss2(ij+u_right,l)/tau_gradrot(l))*itau_dissip 
+            due(ij+u_lup,l)   = -0.5*( due_diss1(ij+u_lup,l)  /tau_graddiv(l) + due_diss2(ij+u_lup,l)  /tau_gradrot(l))*itau_dissip
+            due(ij+u_ldown,l) = -0.5*( due_diss1(ij+u_ldown,l)/tau_graddiv(l) + due_diss2(ij+u_ldown,l)/tau_gradrot(l))*itau_dissip
+
+            dtheta_rhodz(ij,l,1) = -0.5*dtheta_rhodz_diss(ij,l)/tau_divgrad(l)*itau_dissip
+        ENDDO
+      ENDDO
+      !$acc end parallel loop
+
+!      dtheta_rhodz=0
+!      due=0
+
+      IF(rayleigh_friction_type>0) THEN
+        CALL abort_acc("dissip/rayleigh_friction_type>0")
+       IF(rayleigh_friction_type<99) THEN
+         phi=f_geopot(ind)
+         ue=f_ue(ind)
+         DO l=ll_begin,ll_end
+            DO ij=ij_begin,ij_end
+               CALL relax(t_right, u_right)
+               CALL relax(t_lup,   u_lup)
+               CALL relax(t_ldown, u_ldown)
+            ENDDO
+         END DO
+       ELSE
+         ue=f_ue(ind)
+            !$acc parallel loop present(ue(:,:), due(:,:), lat_e(:))
+            DO ij=ij_begin,ij_end
+              nn = ij+u_right
+              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
+                !print*, "latitude", lat_e(nn)*180./3.14159
+                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
+              ENDIF
+              nn = ij+u_lup
+              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
+                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
+              ENDIF
+              nn = ij+u_ldown
+              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
+                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
+              ENDIF
+            ENDDO
+            !$acc end parallel loop
+       ENDIF
+      END IF
+   END DO
+   CALL trace_end("dissip")
+
+   !CALL write_dissip_tendencies
+!$OMP BARRIER
+
+    CONTAINS
+
+      SUBROUTINE relax(shift_t, shift_u)
+        USE dcmip_initial_conditions_test_1_2_3
+        REAL(rstd) :: z, ulon,ulat, & ! input to test2_schaer_mountain
+             p,hyam,hybm,w,t,phis,ps,rho,q, &   ! unused input/output to test2_schaer_mountain
+             fz, u3d(3), uref
+        REAL(rstd), PARAMETER :: zh=2e4,ztop=3e4  ! DCMIP values
+        LOGICAL :: hybrid_eta
+        INTEGER :: shift_u, shift_t, zcoords, nn
+        z = (phi(ij,l)+phi(ij+shift_t,l))/(2.*g)
+        IF(z>zh) THEN  ! relax only in the sponge layer z>zh
+
+           nn = ij+shift_u
+           zcoords = 1 ; hybrid_eta = .FALSE. ! use z instead of p or hyam/hybm
+           CALL test2_schaer_mountain(lon_e(nn),lat_e(nn),p,z,zcoords,hybrid_eta, &
+                hyam,hybm,shear,ulon,ulat,w,t,phis,ps,rho,q)
+!           u3d = ulon*elon_e(nn,:) + ulat*elat_e(nn,:)
+           u3d = ulon*elon_e(nn,:) ! ulat=0
+           uref = sum(u3d*ep_e(nn,:))
+
+           fz = sin((pi/2)*(z-zh)/(ztop-zh))
+           fz = fz*fz/rayleigh_tau
+           due(nn,l) = due(nn,l) - itau_dissip*fz*(ue(nn,l)-uref)
+!           fz = 1./rayleigh_tau
+!           due(nn,l) = due(nn,l) - fz*ue(nn,l)
+         END IF
+       END SUBROUTINE relax
+      
+       SUBROUTINE write_dissip_tendencies
+         USE observable_mod, ONLY : f_buf_ulon, f_buf_ulat
+         USE wind_mod
+         USE output_field_mod
+
+         CALL transfert_request(f_due_diss1,req_e1_vect)
+         CALL un2ulonlat(f_due_diss1, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))
+         CALL output_field("dulon_diss1",f_buf_ulon)
+         CALL output_field("dulat_diss1",f_buf_ulat)
+!
+         CALL transfert_request(f_due_diss2,req_e1_vect)
+         CALL un2ulonlat(f_due_diss2, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))
+         CALL output_field("dulon_diss2",f_buf_ulon)
+         CALL output_field("dulat_diss2",f_buf_ulat)
+       END SUBROUTINE write_dissip_tendencies
+
+  END SUBROUTINE dissip
+
+  SUBROUTINE gradiv(f_ue,f_due)
+  USE icosa
+  USE trace
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field),POINTER :: f_ue(:)
+    TYPE(t_field),POINTER :: f_due(:)
+    REAL(rstd),POINTER    :: ue(:,:)
+    REAL(rstd),POINTER    :: due(:,:)
+    INTEGER :: ind
+    INTEGER :: it,l,ij
+       
+    CALL trace_start("gradiv")
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      ue=f_ue(ind)
+      due=f_due(ind) 
+      !$acc parallel loop present(ue(:,:), due(:,:)) async
+      DO  l = ll_begin, ll_end
+        !$acc loop
+!DIR$ SIMD
+        DO ij=ij_begin,ij_end
+             due(ij+u_right,l)=ue(ij+u_right,l)
+             due(ij+u_lup,l)=ue(ij+u_lup,l)
+             due(ij+u_ldown,l)=ue(ij+u_ldown,l)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    DO it=1,nitergdiv
+      CALL send_message(f_due,req_due)
+      CALL wait_message(req_due)
+
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind)) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        due=f_due(ind)
+        CALL compute_gradiv_inplace(due,ll_begin,ll_end)
+      ENDDO
+    ENDDO
+
+   CALL trace_end("gradiv")
+
+  END SUBROUTINE gradiv
+  
+
+  SUBROUTINE gradrot(f_ue,f_due)
+  USE icosa
+  USE trace
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field),POINTER :: f_ue(:)
+    TYPE(t_field),POINTER :: f_due(:)
+    REAL(rstd),POINTER    :: ue(:,:)
+    REAL(rstd),POINTER    :: due(:,:)
+    INTEGER :: ind
+    INTEGER :: it,l,ij
+       
+    CALL trace_start("gradrot")
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      ue=f_ue(ind)
+      due=f_due(ind) 
+      !$acc parallel loop present(ue(:,:), due(:,:)) async
+      DO  l = ll_begin, ll_end
+         !$acc loop
+!DIR$ SIMD
+        DO ij=ij_begin,ij_end
+             due(ij+u_right,l)=ue(ij+u_right,l)
+             due(ij+u_lup,l)=ue(ij+u_lup,l)
+             due(ij+u_ldown,l)=ue(ij+u_ldown,l)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    DO it=1,nitergrot
+      CALL send_message(f_due,req_due)
+      CALL wait_message(req_due)
+        
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind)) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        due=f_due(ind) 
+        CALL compute_gradrot_inplace(due,ll_begin,ll_end)
+      ENDDO
+
+    ENDDO
+
+    CALL trace_end("gradrot")
+
+  END SUBROUTINE gradrot
+  
+  SUBROUTINE divgrad(f_theta,f_dtheta)
+  USE icosa
+  USE trace
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field),POINTER :: f_theta(:)
+    TYPE(t_field),POINTER :: f_dtheta(:)
+    REAL(rstd),POINTER    :: theta(:,:)
+    REAL(rstd),POINTER    :: dtheta(:,:)
+    INTEGER :: ind, l, ij
+    INTEGER :: it
+
+    CALL trace_start("divgrad")
+       
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      theta=f_theta(ind)
+      dtheta=f_dtheta(ind) 
+      ! Replace Fortran 90 construct dtheta=theta because it confuses PGI acc kernels...
+      !$acc parallel loop collapse(2) present(theta(:,:), dtheta(:,:)) async
+      DO l=ll_begin,ll_end
+!DIR$ SIMD
+        DO ij=1,iim*jjm
+          dtheta(ij,l)=theta(ij,l)
+        ENDDO
+      ENDDO
+      !$acc end parallel loop
+    ENDDO
+
+    DO it=1,niterdivgrad
+      CALL transfert_request(f_dtheta,req_i1)
+        
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind)) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        dtheta=f_dtheta(ind) 
+        CALL compute_divgrad_inplace(dtheta,ll_begin,ll_end)
+      ENDDO
+
+    ENDDO
+
+    CALL trace_end("divgrad")
+
+  END SUBROUTINE divgrad
+   
+  SUBROUTINE divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz)
+  USE icosa
+  USE trace
+  USE omp_para
+  IMPLICIT NONE
+    TYPE(t_field),POINTER :: f_mass(:)
+    TYPE(t_field),POINTER :: f_theta_rhodz(:)
+    TYPE(t_field),POINTER :: f_dtheta_rhodz(:)
+    
+    REAL(rstd),POINTER :: mass(:,:)
+    REAL(rstd),POINTER :: theta_rhodz(:,:,:)
+    REAL(rstd),POINTER :: dtheta_rhodz(:,:)
+
+    INTEGER :: ind
+    INTEGER :: it,l,ij
+
+    CALL trace_start("divgrad")
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      mass=f_mass(ind)
+      theta_rhodz=f_theta_rhodz(ind)
+      dtheta_rhodz=f_dtheta_rhodz(ind) 
+      !$acc parallel loop present(mass(:,:), theta_rhodz(:,:,:), dtheta_rhodz(:,:)) async
+      DO  l = ll_begin, ll_end
+        !$acc loop
+!DIR$ SIMD
+        DO ij=ij_begin,ij_end
+            dtheta_rhodz(ij,l) = theta_rhodz(ij,l,1) / mass(ij,l)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    DO it=1,niterdivgrad
+      CALL send_message(f_dtheta_rhodz,req_dtheta)
+      CALL wait_message(req_dtheta)
+      DO ind=1,ndomain
+        IF (.NOT. assigned_domain(ind)) CYCLE
+        CALL swap_dimensions(ind)
+        CALL swap_geometry(ind)
+        dtheta_rhodz=f_dtheta_rhodz(ind) 
+        CALL compute_divgrad_inplace(dtheta_rhodz,ll_begin,ll_end)
+      ENDDO
+
+    ENDDO
+
+    DO ind=1,ndomain
+      IF (.NOT. assigned_domain(ind)) CYCLE
+      CALL swap_dimensions(ind)
+      CALL swap_geometry(ind)
+      dtheta_rhodz=f_dtheta_rhodz(ind) 
+      mass=f_mass(ind)
+    
+      !$acc parallel loop collapse(2) present(mass(:,:), dtheta_rhodz(:,:)) async
+      DO  l = ll_begin, ll_end
+!DIR$ SIMD
+        DO ij=ij_begin,ij_end
+            dtheta_rhodz(ij,l) = dtheta_rhodz(ij,l) * mass(ij,l)
+        ENDDO
+      ENDDO
+      !$acc end parallel loop
+    ENDDO
+
+
+    CALL trace_end("divgrad")
+
+  END SUBROUTINE divgrad_theta_rhodz
+
+  SUBROUTINE compute_gradiv(ue,gradivu_e,llb,lle)
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(OUT) :: gradivu_e(iim*3*jjm,llm)
+    REAL(rstd),INTENT(IN)  :: ue(iim*3*jjm,llm)
+
+    gradivu_e = ue
+    CALL compute_gradiv_inplace(gradivu_e,llb,lle)
+
+  END SUBROUTINE compute_gradiv
+  
+  SUBROUTINE compute_gradiv_inplace(ue_gradivu_e,llb,lle)
+    USE geometry, ONLY : Ai, ne, le, de
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(INOUT) :: ue_gradivu_e(iim*3*jjm,llm)
+    REAL(rstd) :: divu_i(iim*jjm,llb:lle)
+    
+    INTEGER :: ij,l
+
+    ! ue and gradivu_e second dimension is not always llm so use the bounds explicitly
+    !$acc data present( ue_gradivu_e(:,llb:lle), Ai(:), ne(:,:), le(:), de(:)) create(divu_i(:,:)) async
+
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      !DIR$ SIMD
+      DO ij=ij_begin,ij_end
+          divu_i(ij,l)=1./Ai(ij)*(ne(ij,right)*ue_gradivu_e(ij+u_right,l)*le(ij+u_right)  +  &
+                             ne(ij,rup)*ue_gradivu_e(ij+u_rup,l)*le(ij+u_rup)        +  &  
+                             ne(ij,lup)*ue_gradivu_e(ij+u_lup,l)*le(ij+u_lup)        +  &  
+                             ne(ij,left)*ue_gradivu_e(ij+u_left,l)*le(ij+u_left)     +  &  
+                             ne(ij,ldown)*ue_gradivu_e(ij+u_ldown,l)*le(ij+u_ldown)  +  &  
+                             ne(ij,rdown)*ue_gradivu_e(ij+u_rdown,l)*le(ij+u_rdown))
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+    
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      !DIR$ SIMD
+      DO ij=ij_begin,ij_end
+          ue_gradivu_e(ij+u_right,l)=-1/de(ij+u_right)*(ne(ij,right)*divu_i(ij,l)+ ne(ij+t_right,left)*divu_i(ij+t_right,l) ) 
+          ue_gradivu_e(ij+u_lup,l)=-1/de(ij+u_lup)*(ne(ij,lup)*divu_i(ij,l)+ ne(ij+t_lup,rdown)*divu_i(ij+t_lup,l))   
+          ue_gradivu_e(ij+u_ldown,l)=-1/de(ij+u_ldown)*(ne(ij,ldown)*divu_i(ij,l)+ne(ij+t_ldown,rup)*divu_i(ij+t_ldown,l) )
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      !DIR$ SIMD
+      DO ij=ij_begin,ij_end
+          ue_gradivu_e(ij+u_right,l)=-ue_gradivu_e(ij+u_right,l)*cgraddiv
+          ue_gradivu_e(ij+u_lup,l)=-ue_gradivu_e(ij+u_lup,l)*cgraddiv
+          ue_gradivu_e(ij+u_ldown,l)=-ue_gradivu_e(ij+u_ldown,l)*cgraddiv
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+    !$acc end data   
+  END SUBROUTINE compute_gradiv_inplace
+
+  SUBROUTINE compute_divgrad(theta,divgrad_i,llb,lle)
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(IN) :: theta(iim*jjm,1:lle)
+    REAL(rstd),INTENT(OUT) :: divgrad_i(iim*jjm,1:lle)
+
+    divgrad_i = theta
+    CALL compute_divgrad_inplace(divgrad_i,llb,lle)
+  END SUBROUTINE compute_divgrad
+  
+  SUBROUTINE compute_divgrad_inplace(theta_divgrad_i,llb,lle)
+    USE geometry, ONLY : Ai, ne, le, de
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(INOUT) :: theta_divgrad_i(iim*jjm,1:lle)
+    REAL(rstd)  :: grad_e(3*iim*jjm,llb:lle)
+
+    INTEGER :: ij,l
+
+    ! theta and divgrad_i second dimension is not always llm so use the bounds explicitly
+    !$acc data present(theta_divgrad_i(:,llb:lle), Ai(:), de(:), ne(:,:), le(:)) create(grad_e(:,:)) async
+       
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      !DIR$ SIMD
+      DO ij=ij_begin_ext,ij_end_ext 
+          grad_e(ij+u_right,l)=-1/de(ij+u_right)*(ne(ij,right)*theta_divgrad_i(ij,l)+ ne(ij+t_right,left)*theta_divgrad_i(ij+t_right,l) )
+          grad_e(ij+u_lup,l)=-1/de(ij+u_lup)*(ne(ij,lup)*theta_divgrad_i(ij,l)+ ne(ij+t_lup,rdown)*theta_divgrad_i(ij+t_lup,l ))
+          grad_e(ij+u_ldown,l)=-1/de(ij+u_ldown)*(ne(ij,ldown)*theta_divgrad_i(ij,l)+ne(ij+t_ldown,rup)*theta_divgrad_i(ij+t_ldown,l) )
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+    
+    
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      !DIR$ SIMD
+      DO ij=ij_begin,ij_end
+          theta_divgrad_i(ij,l)=1./Ai(ij)*(ne(ij,right)*grad_e(ij+u_right,l)*le(ij+u_right)  +  &
+                             ne(ij,rup)*grad_e(ij+u_rup,l)*le(ij+u_rup)              +  &
+                             ne(ij,lup)*grad_e(ij+u_lup,l)*le(ij+u_lup)              +  &
+                             ne(ij,left)*grad_e(ij+u_left,l)*le(ij+u_left)           +  &
+                             ne(ij,ldown)*grad_e(ij+u_ldown,l)*le(ij+u_ldown)        +  & 
+                             ne(ij,rdown)*grad_e(ij+u_rdown,l)*le(ij+u_rdown))
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+   
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+      DO ij=ij_begin,ij_end
+          theta_divgrad_i(ij,l)=-theta_divgrad_i(ij,l)*cdivgrad
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+    !$acc end data
+  END SUBROUTINE compute_divgrad_inplace
+
+  SUBROUTINE compute_gradrot(ue,gradrot_e,llb,lle)
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(IN) :: ue(iim*3*jjm,lle)
+    REAL(rstd),INTENT(OUT) :: gradrot_e(iim*3*jjm,lle)
+
+    gradrot_e = ue
+    CALL compute_gradrot_inplace(gradrot_e,llb,lle)
+  END SUBROUTINE compute_gradrot
+
+  SUBROUTINE compute_gradrot_inplace(ue_gradrot_e,llb,lle)
+    USE geometry, ONLY : Av, ne, le, de
+    INTEGER,INTENT(IN)     :: llb
+    INTEGER,INTENT(IN)     :: lle
+    REAL(rstd),INTENT(INOUT) :: ue_gradrot_e(iim*3*jjm,lle)
+    REAL(rstd) :: rot_v(2*iim*jjm,llb:lle)
+
+    INTEGER :: ij,l
+
+    ! ue and gradrot_e second dimension is not always llm so use the bounds explicitly
+    ! gradrot_e should be copyout but using copy instead allows to compare the output
+    ! more easily as the code sometimes uses unintialed values
+    !$acc data present(ue_gradrot_e(:,llb:lle), Av(:), ne(:,:), de(:), le(:)) create(rot_v(:,:)) async
+     
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+!DIR$ SIMD
+      DO ij=ij_begin_ext,ij_end_ext        
+          rot_v(ij+z_up,l)= 1./Av(ij+z_up)*(  ne(ij,rup)*ue_gradrot_e(ij+u_rup,l)*de(ij+u_rup) &
+                                + ne(ij+t_rup,left)*ue_gradrot_e(ij+t_rup+u_left,l)*de(ij+t_rup+u_left) &
+                                - ne(ij,lup)*ue_gradrot_e(ij+u_lup,l)*de(ij+u_lup) )                               
+          rot_v(ij+z_down,l) = 1./Av(ij+z_down)*( ne(ij,ldown)*ue_gradrot_e(ij+u_ldown,l)*de(ij+u_ldown) &
+                                     + ne(ij+t_ldown,right)*ue_gradrot_e(ij+t_ldown+u_right,l)*de(ij+t_ldown+u_right) &
+                                     - ne(ij,rdown)*ue_gradrot_e(ij+u_rdown,l)*de(ij+u_rdown) )
+      ENDDO
+    ENDDO                              
+    !$acc end parallel loop
+  
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+!DIR$ SIMD
+      DO ij=ij_begin,ij_end
+          ue_gradrot_e(ij+u_right,l)=1/le(ij+u_right)*ne(ij,right)*(rot_v(ij+z_rdown,l)-rot_v(ij+z_rup,l))       
+          ue_gradrot_e(ij+u_lup,l)=1/le(ij+u_lup)*ne(ij,lup)*(rot_v(ij+z_up,l)-rot_v(ij+z_lup,l))        
+          ue_gradrot_e(ij+u_ldown,l)=1/le(ij+u_ldown)*ne(ij,ldown)*(rot_v(ij+z_ldown,l)-rot_v(ij+z_down,l))
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+
+    !$acc parallel loop collapse(2) async
+    DO l=llb,lle
+!DIR$ SIMD
+      DO ij=ij_begin,ij_end    
+          ue_gradrot_e(ij+u_right,l)=-ue_gradrot_e(ij+u_right,l)*cgradrot       
+          ue_gradrot_e(ij+u_lup,l)=-ue_gradrot_e(ij+u_lup,l)*cgradrot
+          ue_gradrot_e(ij+u_ldown,l)=-ue_gradrot_e(ij+u_ldown,l)*cgradrot        
+      ENDDO
+    ENDDO
+    !$acc end parallel loop
+    !$acc end data   
+  END SUBROUTINE compute_gradrot_inplace
+
+
+END MODULE dissip_gcm_mod
Index: codes/icosagcm/trunk/src/dissip/dissip_gcm.f90
===================================================================
--- codes/icosagcm/trunk/src/dissip/dissip_gcm.f90	(revision 926)
+++ 	(revision )
@@ -1,996 +1,0 @@
-MODULE dissip_gcm_mod
-  USE icosa
-
-  PRIVATE
-
-  TYPE(t_field),POINTER,SAVE :: f_due_diss1(:)
-  TYPE(t_field),POINTER,SAVE :: f_due_diss2(:)
-
-  TYPE(t_field),POINTER,SAVE :: f_dtheta_diss(:)
-  TYPE(t_field),POINTER,SAVE :: f_dtheta_rhodz_diss(:)
-  TYPE(t_message),SAVE :: req_due, req_dtheta 
- 
-  INTEGER,SAVE :: nitergdiv=1
-!$OMP THREADPRIVATE(nitergdiv)
-  INTEGER,SAVE :: nitergrot=1
-!$OMP THREADPRIVATE(nitergrot)
-  INTEGER,SAVE :: niterdivgrad=1
-!$OMP THREADPRIVATE(niterdivgrad)
-
-  REAL,ALLOCATABLE,SAVE :: tau_graddiv(:)
-!$OMP THREADPRIVATE(tau_graddiv)
-  REAL,ALLOCATABLE,SAVE :: tau_gradrot(:)
-!$OMP THREADPRIVATE(tau_gradrot)
-  REAL,ALLOCATABLE,SAVE :: tau_divgrad(:)
-!$OMP THREADPRIVATE(tau_divgrad)
-  
-  REAL,SAVE :: cgraddiv
-!$OMP THREADPRIVATE(cgraddiv)
-  REAL,SAVE :: cgradrot
-!$OMP THREADPRIVATE(cgradrot)
-  REAL,SAVE :: cdivgrad
-!$OMP THREADPRIVATE(cdivgrad)
-
-  INTEGER, SAVE :: rayleigh_friction_type, rayleigh_shear
-!$OMP THREADPRIVATE(rayleigh_friction_type)
-!$OMP THREADPRIVATE(rayleigh_shear)
-  REAL, SAVE    :: rayleigh_tau, rayleigh_limlat
-!$OMP THREADPRIVATE(rayleigh_tau)
-!$OMP THREADPRIVATE(rayleigh_limlat)
-  
-  REAL,SAVE    :: dtdissip
-!$OMP THREADPRIVATE(dtdissip)
- 
-  PUBLIC init_dissip, dissip
-CONTAINS
-
-  SUBROUTINE allocate_dissip
-  USE icosa
-  IMPLICIT NONE  
-    CALL allocate_field(f_due_diss1,field_u,type_real,llm)
-    CALL allocate_field(f_due_diss2,field_u,type_real,llm)
-    CALL allocate_field(f_dtheta_diss,field_t,type_real,llm)
-    CALL allocate_field(f_dtheta_rhodz_diss,field_t,type_real,llm)
-    ALLOCATE(tau_graddiv(llm))
-    ALLOCATE(tau_gradrot(llm))    
-    ALLOCATE(tau_divgrad(llm))
-  END SUBROUTINE allocate_dissip
- 
-  SUBROUTINE init_dissip
-  USE icosa
-  USE disvert_mod
-  USE mpi_mod
-  USE mpipara
-  USE transfert_mod
-  USE time_mod
-  USE transfert_omp_mod
-  USE omp_para
-  IMPLICIT NONE
-  
-  TYPE(t_field),POINTER,SAVE  :: f_u(:)
-  TYPE(t_field),POINTER,SAVE  :: f_du(:)
-  REAL(rstd),POINTER     :: u(:)
-  REAL(rstd),POINTER     :: du(:)
-  TYPE(t_field),POINTER,SAVE  :: f_theta(:)
-  TYPE(t_field),POINTER ,SAVE :: f_dtheta(:)
-  REAL(rstd),POINTER    :: theta(:)
-  REAL(rstd),POINTER    :: dtheta(:)
-  REAL(rstd)            :: dumax,dumax1
-  REAL(rstd)            :: dthetamax,dthetamax1
-  REAL(rstd)            :: r
-  REAL(rstd)            :: tau
-  REAL(rstd)            :: zz, zvert, fact
-  INTEGER               :: l
-  CHARACTER(len=255)    :: rayleigh_friction_key
-  REAL(rstd)            :: mintau
-  
-  ! New variables added for dissipation vertical profile (SF, 19/09/18)
-  INTEGER    :: vert_prof_dissip
-  REAL(rstd) :: dissip_factz,dissip_deltaz,dissip_zref,pseudoz
-                        
-  INTEGER :: i,j,ij,ind,it,iter,M
-
-   rayleigh_friction_key='none'
-   CALL getin("rayleigh_friction_type",rayleigh_friction_key)
-   SELECT CASE(TRIM(rayleigh_friction_key))
-   CASE('none')
-      rayleigh_friction_type=0
-      IF (is_master) PRINT *, 'No Rayleigh friction'
-   CASE('dcmip2_schaer_noshear')
-      rayleigh_friction_type=1
-      rayleigh_shear=0
-      IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain without shear DCMIP2.1'
-   CASE('dcmip2_schaer_shear')
-      rayleigh_shear=1
-      rayleigh_friction_type=2
-      IF (is_master) PRINT *, 'Rayleigh friction : Schaer-like mountain with shear DCMIP2.2'
-   CASE('giant_liu_schneider') 
-      rayleigh_friction_type=99
-      IF (is_master) PRINT *, 'Rayleigh friction : giant planets Liu Schneider 2010'
-   CASE DEFAULT
-      IF (is_master) PRINT *, 'Bad selector : rayleigh_friction_type =', TRIM(rayleigh_friction_key), &
-        ' in dissip_gcm.f90/init_dissip'
-      STOP
-   END SELECT
-
-   IF(rayleigh_friction_type>0) THEN
-      rayleigh_tau=0.
-      CALL getin("rayleigh_friction_tau",rayleigh_tau)
-      rayleigh_tau = rayleigh_tau / scale_factor
-      IF(rayleigh_tau<=0) THEN
-         IF (is_master) PRINT *, 'Forbidden : negative value for rayleigh_friction_tau =',rayleigh_tau
-         STOP
-      END IF
-      IF(rayleigh_friction_type == 99) THEN
-         rayleigh_limlat=0.
-         CALL getin("rayleigh_limlat",rayleigh_limlat)
-         rayleigh_limlat = rayleigh_limlat*3.14159/180.
-      ENDIF
-   END IF
-
-    CALL allocate_dissip
-    CALL allocate_field(f_u,field_u,type_real)
-    CALL allocate_field(f_du,field_u,type_real)
-    CALL allocate_field(f_theta,field_t,type_real)
-    CALL allocate_field(f_dtheta,field_t,type_real)
-    
-    CALL init_message(f_due_diss1,req_e1_vect,req_due)
-    CALL init_message(f_dtheta_diss,req_i1,req_dtheta)
-
-    tau_graddiv(:)=5000
-    CALL getin("tau_graddiv",tau)
-    tau_graddiv(:)=tau/scale_factor
-
-    CALL getin("nitergdiv",nitergdiv)
-    
-    tau_gradrot(:)=5000
-    CALL getin("tau_gradrot",tau)
-    tau_gradrot(:)=tau/scale_factor
-
-    CALL getin("nitergrot",nitergrot)
-    
-
-    tau_divgrad(:)=5000
-    CALL getin("tau_divgrad",tau)
-    tau_divgrad(:)=tau/scale_factor
-
-    CALL getin("niterdivgrad",niterdivgrad)
-
-
-    cgraddiv=-1
-    cdivgrad=-1
-    cgradrot=-1
-
-!$OMP BARRIER
-!$OMP MASTER
-    DO ind=1,ndomain
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      u=f_u(ind)
-
-! set random seed to get reproductibility when using a different number of process
-      CALL RANDOM_SEED(size=M)
-      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
-
-      DO j=jj_begin,jj_end
-        DO i=ii_begin,ii_end
-          ij=(j-1)*iim+i   
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_right)=r-0.5
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_lup)=r-0.5
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_ldown)=r-0.5
-        ENDDO
-      ENDDO        
-    ENDDO
-!$OMP END MASTER  
-!$OMP BARRIER
-
-    DO it=1,20
-      
-      dumax=0
-      DO iter=1,nitergdiv
-        CALL transfert_request(f_u,req_e1_vect)
-        DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-          CALL swap_dimensions(ind)
-          CALL swap_geometry(ind)
-          u=f_u(ind)
-          du=f_du(ind)
-          CALL compute_gradiv_inplace(u,1,1)
-          du=u
-        ENDDO
-      ENDDO
-
-      CALL transfert_request(f_du,req_e1_vect)
-      
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        u=f_u(ind)
-        du=f_du(ind)
-         
-        DO j=jj_begin,jj_end
-          DO i=ii_begin,ii_end
-            ij=(j-1)*iim+i   
-            if (le(ij+u_right)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_right)))
-            if (le(ij+u_lup)>1e-100)   dumax=MAX(dumax,ABS(du(ij+u_lup)))
-            if (le(ij+u_ldown)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_ldown)))
-          ENDDO
-        ENDDO
-      ENDDO
-
-      IF (using_mpi) THEN 
-        CALL reduce_max_omp(dumax,dumax1)
-!$OMP MASTER        
-        CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
-!$OMP END MASTER     
-        CALL bcast_omp(dumax)  
-      ELSE
-        CALL allreduce_max_omp(dumax,dumax1)
-        dumax=dumax1
-      ENDIF  
-			
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        u=f_u(ind)
-        du=f_du(ind)
-        u=du/dumax
-      ENDDO
-      IF (is_master) PRINT *,"gradiv : it :",it ,": dumax",dumax
-
-    ENDDO 
-    IF (is_master) PRINT *,"gradiv : dumax",dumax
-    IF (is_master) PRINT *, 'mean T-cell edge size (km)', 1.45*radius/iim_glo/1000., &
-                              'effective T-cell half-edge size (km)', dumax**(-.5/nitergdiv)/1000
-    IF (is_master)  PRINT *, 'Max. time step assuming c=340 m/s and Courant number=3 (ARK2.3) :', &
-                               3./340.*dumax**(-.5/nitergdiv)
-
-    cgraddiv=dumax**(-1./nitergdiv)
-    IF (is_master) PRINT *,"cgraddiv : ",cgraddiv
-
-!$OMP BARRIER
-!$OMP MASTER
-    DO ind=1,ndomain
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      u=f_u(ind)
-
-! set random seed to get reproductibility when using a different number of process
-      CALL RANDOM_SEED(size=M)
-      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
- 
-       DO j=jj_begin,jj_end
-        DO i=ii_begin,ii_end
-          ij=(j-1)*iim+i   
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_right)=r-0.5
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_lup)=r-0.5
-          CALL RANDOM_NUMBER(r)
-          u(ij+u_ldown)=r-0.5
-        ENDDO
-      ENDDO        
-    ENDDO
-!$OMP END MASTER  
-!$OMP BARRIER
-
-
-    DO it=1,20
- 
-      dumax=0
-      DO iter=1,nitergrot
-        CALL transfert_request(f_u,req_e1_vect)
-        DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-          CALL swap_dimensions(ind)
-          CALL swap_geometry(ind)
-          u=f_u(ind)
-          du=f_du(ind)
-          CALL compute_gradrot_inplace(u,1,1)
-          du=u
-        ENDDO
-      ENDDO
-
-      CALL transfert_request(f_du,req_e1_vect)
-      
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        u=f_u(ind)
-        du=f_du(ind)
-        
-        DO j=jj_begin,jj_end
-          DO i=ii_begin,ii_end
-            ij=(j-1)*iim+i   
-            if (le(ij+u_right)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_right)))
-            if (le(ij+u_lup)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_lup)))
-            if (le(ij+u_ldown)>1e-100) dumax=MAX(dumax,ABS(du(ij+u_ldown)))
-          ENDDO
-        ENDDO
-      ENDDO
-
-      IF (using_mpi) THEN 
-        CALL reduce_max_omp(dumax,dumax1)
-!$OMP MASTER        
-        CALL MPI_ALLREDUCE(dumax1,dumax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
-!$OMP END MASTER     
-        CALL bcast_omp(dumax)  
-      ELSE
-        CALL allreduce_max_omp(dumax,dumax1)
-        dumax=dumax1
-      ENDIF  
-
-      
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        u=f_u(ind)
-        du=f_du(ind)
-        u=du/dumax
-      ENDDO
-      
-      IF (is_master) PRINT *,"gradrot : it :",it ,": dumax",dumax
-
-    ENDDO 
-    IF (is_master) PRINT *,"gradrot : dumax",dumax
-  
-    cgradrot=dumax**(-1./nitergrot) 
-    IF (is_master) PRINT *,"cgradrot : ",cgradrot
-   
-
-
-!$OMP BARRIER
-!$OMP MASTER
-    DO ind=1,ndomain
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      theta=f_theta(ind)
-
-! set random seed to get reproductibility when using a different number of process
-      CALL RANDOM_SEED(size=M)
-      CALL RANDOM_SEED(put=(/(i,i=1,M)/))
-
-      DO j=jj_begin,jj_end
-        DO i=ii_begin,ii_end
-          ij=(j-1)*iim+i   
-          CALL RANDOM_NUMBER(r)
-          theta(ij)=r-0.5
-        ENDDO
-      ENDDO  
-    ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-    DO it=1,20
-
-      dthetamax=0
-      DO iter=1,niterdivgrad
-        CALL transfert_request(f_theta,req_i1)
-        DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-          CALL swap_dimensions(ind)
-          CALL swap_geometry(ind)
-          theta=f_theta(ind)
-          dtheta=f_dtheta(ind)
-          CALL compute_divgrad_inplace(theta,1,1)
-          dtheta=theta
-        ENDDO
-      ENDDO
-
-      CALL transfert_request(f_dtheta,req_i1)
-      
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        theta=f_theta(ind)
-        dtheta=f_dtheta(ind)
-        
-        DO j=jj_begin,jj_end
-          DO i=ii_begin,ii_end
-            ij=(j-1)*iim+i   
-            dthetamax=MAX(dthetamax,ABS(dtheta(ij)))
-          ENDDO
-        ENDDO
-      ENDDO
-
-      IF (using_mpi) THEN 
-        CALL reduce_max_omp(dthetamax ,dthetamax1)
-!$OMP MASTER        
-        CALL MPI_ALLREDUCE(dthetamax1,dthetamax,1,MPI_REAL8,MPI_MAX,comm_icosa,ierr)
-!$OMP END MASTER     
-        CALL bcast_omp(dthetamax)  
-      ELSE
-        CALL allreduce_max_omp(dthetamax,dthetamax1)
-        dumax=dumax1
-      ENDIF  
-      
-      IF (is_master) PRINT *,"divgrad : it :",it ,": dthetamax",dthetamax
-
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        theta=f_theta(ind)
-        dtheta=f_dtheta(ind)
-        theta=dtheta/dthetamax
-      ENDDO
-    ENDDO 
-
-    IF (is_master) PRINT *,"divgrad : divgrad",dthetamax
-  
-    cdivgrad=dthetamax**(-1./niterdivgrad) 
-    IF (is_master) PRINT *,"cdivgrad : ",cdivgrad
-
-    ! Added CMIP5 dissipation vertical profile (SF, 19/09/18)
-    vert_prof_dissip = 1
-    CALL getin('vert_prof_dissip',vert_prof_dissip)
-    IF (vert_prof_dissip == 1) then
-       dissip_zref = 30.
-       dissip_deltaz = 10.
-       dissip_factz = 4.
-       CALL getin('dissip_factz',dissip_factz )
-       CALL getin('dissip_deltaz',dissip_deltaz )
-       CALL getin('dissip_zref',dissip_zref )
-       DO l=1,llm
-          pseudoz=8.*log(preff/presnivs(l))
-          zvert=1+ &
-               (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. &
-               *(dissip_factz-1.)
-          tau_graddiv(l) = tau_graddiv(l)/zvert
-          tau_gradrot(l) = tau_gradrot(l)/zvert
-          tau_divgrad(l) = tau_divgrad(l)/zvert
-       ENDDO
-    ELSE     
-       fact=2
-       DO l=1,llm
-          IF(ap_bp_present) THEN ! height-dependent dissipation
-             zz= 1. - preff/presnivs(l)
-          ELSE
-             zz = 0.
-          END IF
-          zvert=fact-(fact-1)/(1+zz*zz)
-          tau_graddiv(l) = tau_graddiv(l)/zvert
-          tau_gradrot(l) = tau_gradrot(l)/zvert
-          tau_divgrad(l) = tau_divgrad(l)/zvert
-       ENDDO
-    ENDIF
-
-    mintau=tau_graddiv(1)
-    DO l=1,llm
-      mintau=MIN(mintau,tau_graddiv(l))
-      mintau=MIN(mintau,tau_gradrot(l))
-      mintau=MIN(mintau,tau_divgrad(l))
-    ENDDO
-
-    IF(rayleigh_friction_type>0) mintau=MIN(mintau,rayleigh_tau)
-
-    IF(mintau>0) THEN
-       IF (itau_dissip==0) THEN
-         IF (is_master) PRINT *,"init_dissip: Automatic computation of itau_dissip..."
-         itau_dissip=INT(mintau/dt)
-       ENDIF
-    ELSE
-       IF (is_master) PRINT *,"init_dissip: No dissipation time set, setting itau_dissip to 1000000000"
-       itau_dissip=100000000
-    END IF
-    itau_dissip=MAX(1,itau_dissip)
-    dtdissip=itau_dissip*dt
-    IF (is_master) THEN
-      PRINT *,"init_dissip: rayleigh_tau",rayleigh_tau, "mintau ",mintau
-      PRINT *,"init_dissip: itau_dissip",itau_dissip," dtdissip ",dtdissip
-    ENDIF
-
-  END SUBROUTINE init_dissip 
- 
-  
-  SUBROUTINE dissip(f_ps,f_mass,f_phis,f_geopot,f_theta_rhodz,f_ue, f_dtheta_rhodz,f_due)
-  USE icosa
-  USE theta2theta_rhodz_mod
-  USE pression_mod
-  USE exner_mod
-  USE geopotential_mod
-  USE trace
-  USE time_mod
-  USE omp_para
-  IMPLICIT NONE
-    TYPE(t_field),POINTER :: f_ps(:), f_mass(:), f_phis(:), f_geopot(:)
-    TYPE(t_field),POINTER :: f_theta_rhodz(:), f_dtheta_rhodz(:)
-    TYPE(t_field),POINTER :: f_ue(:), f_due(:)
-
-    REAL(rstd),POINTER         :: due(:,:)
-    REAL(rstd),POINTER         :: phi(:,:), ue(:,:)
-    REAL(rstd),POINTER         :: due_diss1(:,:)
-    REAL(rstd),POINTER         :: due_diss2(:,:)
-    REAL(rstd),POINTER         :: dtheta_rhodz(:,:,:)
-    REAL(rstd),POINTER         :: dtheta_rhodz_diss(:,:)
-
-    INTEGER :: ind, shear
-    INTEGER :: l,ij,nn
-
-!$OMP BARRIER
-    
-    CALL trace_start("dissip")
-    CALL gradiv(f_ue,f_due_diss1)
-    CALL gradrot(f_ue,f_due_diss2)
-
-    CALL divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz_diss)
-    
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      due=f_due(ind) 
-      due_diss1=f_due_diss1(ind)
-      due_diss2=f_due_diss2(ind)
-      dtheta_rhodz=f_dtheta_rhodz(ind)
-      dtheta_rhodz_diss=f_dtheta_rhodz_diss(ind)
-
-      DO l=ll_begin,ll_end
-!DIR$ SIMD
-        DO ij=ij_begin,ij_end
-
-            due(ij+u_right,l) = -0.5*( due_diss1(ij+u_right,l)/tau_graddiv(l) + due_diss2(ij+u_right,l)/tau_gradrot(l))*itau_dissip 
-            due(ij+u_lup,l)   = -0.5*( due_diss1(ij+u_lup,l)  /tau_graddiv(l) + due_diss2(ij+u_lup,l)  /tau_gradrot(l))*itau_dissip
-            due(ij+u_ldown,l) = -0.5*( due_diss1(ij+u_ldown,l)/tau_graddiv(l) + due_diss2(ij+u_ldown,l)/tau_gradrot(l))*itau_dissip
-
-            dtheta_rhodz(ij,l,1) = -0.5*dtheta_rhodz_diss(ij,l)/tau_divgrad(l)*itau_dissip
-        ENDDO
-      ENDDO
-
-!      dtheta_rhodz=0
-!      due=0
-
-      IF(rayleigh_friction_type>0) THEN
-       IF(rayleigh_friction_type<99) THEN
-         phi=f_geopot(ind)
-         ue=f_ue(ind)
-         DO l=ll_begin,ll_end
-            DO ij=ij_begin,ij_end
-               CALL relax(t_right, u_right)
-               CALL relax(t_lup,   u_lup)
-               CALL relax(t_ldown, u_ldown)
-            ENDDO
-         END DO
-       ELSE
-         ue=f_ue(ind)
-            DO ij=ij_begin,ij_end
-              nn = ij+u_right
-              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
-                !print*, "latitude", lat_e(nn)*180./3.14159
-                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
-              ENDIF
-              nn = ij+u_lup
-              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
-                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
-              ENDIF
-              nn = ij+u_ldown
-              IF (ABS(lat_e(nn)) .gt. rayleigh_limlat) THEN
-                due(nn,ll_begin:ll_begin+1) = due(nn,ll_begin:ll_begin+1) - (ue(nn,ll_begin:ll_begin+1)/rayleigh_tau)
-              ENDIF
-            ENDDO
-       ENDIF
-      END IF
-   END DO
-
-   CALL trace_end("dissip")
-
-!   CALL write_dissip_tendencies
-!$OMP BARRIER
-
-    CONTAINS
-
-      SUBROUTINE relax(shift_t, shift_u)
-        USE dcmip_initial_conditions_test_1_2_3
-        REAL(rstd) :: z, ulon,ulat, & ! input to test2_schaer_mountain
-             p,hyam,hybm,w,t,phis,ps,rho,q, &   ! unused input/output to test2_schaer_mountain
-             fz, u3d(3), uref
-        REAL(rstd), PARAMETER :: zh=2e4,ztop=3e4  ! DCMIP values
-        LOGICAL :: hybrid_eta
-        INTEGER :: shift_u, shift_t, zcoords, nn
-        z = (phi(ij,l)+phi(ij+shift_t,l))/(2.*g)
-        IF(z>zh) THEN  ! relax only in the sponge layer z>zh
-
-           nn = ij+shift_u
-           zcoords = 1 ; hybrid_eta = .FALSE. ! use z instead of p or hyam/hybm
-           CALL test2_schaer_mountain(lon_e(nn),lat_e(nn),p,z,zcoords,hybrid_eta, &
-                hyam,hybm,shear,ulon,ulat,w,t,phis,ps,rho,q)
-!           u3d = ulon*elon_e(nn,:) + ulat*elat_e(nn,:)
-           u3d = ulon*elon_e(nn,:) ! ulat=0
-           uref = sum(u3d*ep_e(nn,:))
-
-           fz = sin((pi/2)*(z-zh)/(ztop-zh))
-           fz = fz*fz/rayleigh_tau
-           due(nn,l) = due(nn,l) - itau_dissip*fz*(ue(nn,l)-uref)
-!           fz = 1./rayleigh_tau
-!           due(nn,l) = due(nn,l) - fz*ue(nn,l)
-         END IF
-       END SUBROUTINE relax
-      
-       SUBROUTINE write_dissip_tendencies
-         USE observable_mod, ONLY : f_buf_ulon, f_buf_ulat
-         USE wind_mod
-         USE output_field_mod
-
-         CALL transfert_request(f_due_diss1,req_e1_vect)
-         CALL un2ulonlat(f_due_diss1, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))
-         CALL output_field("dulon_diss1",f_buf_ulon)
-         CALL output_field("dulat_diss1",f_buf_ulat)
-!
-         CALL transfert_request(f_due_diss2,req_e1_vect)
-         CALL un2ulonlat(f_due_diss2, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))
-         CALL output_field("dulon_diss2",f_buf_ulon)
-         CALL output_field("dulat_diss2",f_buf_ulat)
-       END SUBROUTINE write_dissip_tendencies
-
-  END SUBROUTINE dissip
-
-  SUBROUTINE gradiv(f_ue,f_due)
-  USE icosa
-  USE trace
-  USE omp_para
-  IMPLICIT NONE
-    TYPE(t_field),POINTER :: f_ue(:)
-    TYPE(t_field),POINTER :: f_due(:)
-    REAL(rstd),POINTER    :: ue(:,:)
-    REAL(rstd),POINTER    :: due(:,:)
-    INTEGER :: ind
-    INTEGER :: it,l,ij
-       
-    CALL trace_start("gradiv")
-
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      ue=f_ue(ind)
-      due=f_due(ind) 
-      DO  l = ll_begin, ll_end
-!DIR$ SIMD
-        DO ij=ij_begin,ij_end
-             due(ij+u_right,l)=ue(ij+u_right,l)
-             due(ij+u_lup,l)=ue(ij+u_lup,l)
-             due(ij+u_ldown,l)=ue(ij+u_ldown,l)
-        ENDDO
-      ENDDO
-    ENDDO
-
-    DO it=1,nitergdiv
-        
-      CALL send_message(f_due,req_due)
-      CALL wait_message(req_due)
-        
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind)) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        due=f_due(ind) 
-        CALL compute_gradiv_inplace(due,ll_begin,ll_end)
-      ENDDO
-    ENDDO
-
-   CALL trace_end("gradiv")
-
-  END SUBROUTINE gradiv
-  
-
-  SUBROUTINE gradrot(f_ue,f_due)
-  USE icosa
-  USE trace
-  USE omp_para
-  IMPLICIT NONE
-    TYPE(t_field),POINTER :: f_ue(:)
-    TYPE(t_field),POINTER :: f_due(:)
-    REAL(rstd),POINTER    :: ue(:,:)
-    REAL(rstd),POINTER    :: due(:,:)
-    INTEGER :: ind
-    INTEGER :: it,l,ij
-       
-    CALL trace_start("gradrot")
-
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      ue=f_ue(ind)
-      due=f_due(ind) 
-      DO  l = ll_begin, ll_end
-!DIR$ SIMD
-        DO ij=ij_begin,ij_end
-             due(ij+u_right,l)=ue(ij+u_right,l)
-             due(ij+u_lup,l)=ue(ij+u_lup,l)
-             due(ij+u_ldown,l)=ue(ij+u_ldown,l)
-        ENDDO
-      ENDDO
-    ENDDO
-
-    DO it=1,nitergrot
-        
-      CALL send_message(f_due,req_due)
-      CALL wait_message(req_due)
-        
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind)) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        due=f_due(ind) 
-        CALL compute_gradrot_inplace(due,ll_begin,ll_end)
-      ENDDO
-
-    ENDDO
-
-    CALL trace_end("gradrot")
-
-  END SUBROUTINE gradrot
-  
-  SUBROUTINE divgrad(f_theta,f_dtheta)
-  USE icosa
-  USE trace
-  USE omp_para
-  IMPLICIT NONE
-    TYPE(t_field),POINTER :: f_theta(:)
-    TYPE(t_field),POINTER :: f_dtheta(:)
-    REAL(rstd),POINTER    :: theta(:,:)
-    REAL(rstd),POINTER    :: dtheta(:,:)
-    INTEGER :: ind
-    INTEGER :: it
-
-    CALL trace_start("divgrad")
-       
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      theta=f_theta(ind)
-      dtheta=f_dtheta(ind) 
-      dtheta=theta
-    ENDDO
-
-    DO it=1,niterdivgrad
-        
-      CALL transfert_request(f_dtheta,req_i1)
-        
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind)) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        dtheta=f_dtheta(ind) 
-        CALL compute_divgrad_inplace(dtheta,ll_begin,ll_end)
-      ENDDO
-
-    ENDDO
-
-    CALL trace_end("divgrad")
-
-  END SUBROUTINE divgrad
-   
-  SUBROUTINE divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz)
-  USE icosa
-  USE trace
-  USE omp_para
-  IMPLICIT NONE
-    TYPE(t_field),POINTER :: f_mass(:)
-    TYPE(t_field),POINTER :: f_theta_rhodz(:)
-    TYPE(t_field),POINTER :: f_dtheta_rhodz(:)
-    
-    REAL(rstd),POINTER :: mass(:,:)
-    REAL(rstd),POINTER :: theta_rhodz(:,:,:)
-    REAL(rstd),POINTER :: dtheta_rhodz(:,:)
-
-    INTEGER :: ind
-    INTEGER :: it,l,ij
-
-    CALL trace_start("divgrad")
-
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      mass=f_mass(ind)
-      theta_rhodz=f_theta_rhodz(ind)
-      dtheta_rhodz=f_dtheta_rhodz(ind) 
-      DO  l = ll_begin, ll_end
-!DIR$ SIMD
-        DO ij=ij_begin,ij_end
-            dtheta_rhodz(ij,l) = theta_rhodz(ij,l,1) / mass(ij,l)
-        ENDDO
-      ENDDO
-    ENDDO
-
-    DO it=1,niterdivgrad
-        
-      CALL send_message(f_dtheta_rhodz,req_dtheta)
-      CALL wait_message(req_dtheta)
-      DO ind=1,ndomain
-        IF (.NOT. assigned_domain(ind)) CYCLE
-        CALL swap_dimensions(ind)
-        CALL swap_geometry(ind)
-        dtheta_rhodz=f_dtheta_rhodz(ind) 
-        CALL compute_divgrad_inplace(dtheta_rhodz,ll_begin,ll_end)
-      ENDDO
-
-    ENDDO
-
-    DO ind=1,ndomain
-      IF (.NOT. assigned_domain(ind)) CYCLE
-      CALL swap_dimensions(ind)
-      CALL swap_geometry(ind)
-      dtheta_rhodz=f_dtheta_rhodz(ind) 
-      mass=f_mass(ind)
-    
-      DO  l = ll_begin, ll_end
-!DIR$ SIMD
-        DO ij=ij_begin,ij_end
-            dtheta_rhodz(ij,l) = dtheta_rhodz(ij,l) * mass(ij,l)
-        ENDDO
-      ENDDO
-    ENDDO
-
-
-    CALL trace_end("divgrad")
-
-  END SUBROUTINE divgrad_theta_rhodz  
-  
-  SUBROUTINE compute_gradiv(ue,gradivu_e,llb,lle)
-  USE icosa
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(IN)  :: ue(iim*3*jjm,llm)
-    REAL(rstd),INTENT(OUT) :: gradivu_e(iim*3*jjm,llm)
-    
-    gradivu_e = ue
-    CALL compute_gradiv_inplace(gradivu_e, llb, lle)
-  END SUBROUTINE compute_gradiv
-  
-  SUBROUTINE compute_gradiv_inplace(ue_gradivu_e,llb,lle)
-  USE icosa
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(INOUT) :: ue_gradivu_e(iim*3*jjm,llm)
-    REAL(rstd) :: divu_i(iim*jjm,llb:lle)
-    
-    INTEGER :: ij,l
-
-    DO l=llb,lle
-      !DIR$ SIMD
-      DO ij=ij_begin,ij_end
-          divu_i(ij,l)=1./Ai(ij)*(ne(ij,right)*ue_gradivu_e(ij+u_right,l)*le(ij+u_right)  +  &
-                             ne(ij,rup)*ue_gradivu_e(ij+u_rup,l)*le(ij+u_rup)        +  &  
-                             ne(ij,lup)*ue_gradivu_e(ij+u_lup,l)*le(ij+u_lup)        +  &  
-                             ne(ij,left)*ue_gradivu_e(ij+u_left,l)*le(ij+u_left)     +  &  
-                             ne(ij,ldown)*ue_gradivu_e(ij+u_ldown,l)*le(ij+u_ldown)  +  &  
-                             ne(ij,rdown)*ue_gradivu_e(ij+u_rdown,l)*le(ij+u_rdown))
-      ENDDO
-    ENDDO
-    
-    DO l=llb,lle
-      !DIR$ SIMD
-      DO ij=ij_begin,ij_end
-          ue_gradivu_e(ij+u_right,l)=-1/de(ij+u_right)*(ne(ij,right)*divu_i(ij,l)+ ne(ij+t_right,left)*divu_i(ij+t_right,l) ) 
-          ue_gradivu_e(ij+u_lup,l)=-1/de(ij+u_lup)*(ne(ij,lup)*divu_i(ij,l)+ ne(ij+t_lup,rdown)*divu_i(ij+t_lup,l))   
-          ue_gradivu_e(ij+u_ldown,l)=-1/de(ij+u_ldown)*(ne(ij,ldown)*divu_i(ij,l)+ne(ij+t_ldown,rup)*divu_i(ij+t_ldown,l) )
-      ENDDO
-    ENDDO
-
-    DO l=llb,lle
-      !DIR$ SIMD
-      DO ij=ij_begin,ij_end
-          ue_gradivu_e(ij+u_right,l)=-ue_gradivu_e(ij+u_right,l)*cgraddiv
-          ue_gradivu_e(ij+u_lup,l)=-ue_gradivu_e(ij+u_lup,l)*cgraddiv
-          ue_gradivu_e(ij+u_ldown,l)=-ue_gradivu_e(ij+u_ldown,l)*cgraddiv
-      ENDDO
-    ENDDO   
-  END SUBROUTINE compute_gradiv_inplace
-  
-  SUBROUTINE compute_divgrad(theta,divgrad_i,llb,lle)
-  USE icosa
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(IN) :: theta(iim*jjm,1:lle)
-    REAL(rstd),INTENT(OUT) :: divgrad_i(iim*jjm,1:lle)
-    
-    divgrad_i = theta
-    CALL compute_divgrad_inplace(divgrad_i, llb, lle)
-  END SUBROUTINE
-  
-  SUBROUTINE compute_divgrad_inplace(theta_divgrad_i,llb,lle)
-  USE icosa
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(INOUT) :: theta_divgrad_i(iim*jjm,1:lle)
-    REAL(rstd)  :: grad_e(3*iim*jjm,llb:lle)
-
-    INTEGER :: ij,l    
-    DO l=llb,lle
-      !DIR$ SIMD
-      DO ij=ij_begin_ext,ij_end_ext 
-          grad_e(ij+u_right,l)=-1/de(ij+u_right)*(ne(ij,right)*theta_divgrad_i(ij,l)+ ne(ij+t_right,left)*theta_divgrad_i(ij+t_right,l) )
-          grad_e(ij+u_lup,l)=-1/de(ij+u_lup)*(ne(ij,lup)*theta_divgrad_i(ij,l)+ ne(ij+t_lup,rdown)*theta_divgrad_i(ij+t_lup,l ))
-          grad_e(ij+u_ldown,l)=-1/de(ij+u_ldown)*(ne(ij,ldown)*theta_divgrad_i(ij,l)+ne(ij+t_ldown,rup)*theta_divgrad_i(ij+t_ldown,l) )
-      ENDDO
-    ENDDO    
-    
-    DO l=llb,lle
-      !DIR$ SIMD
-      DO ij=ij_begin,ij_end
-          theta_divgrad_i(ij,l)=1./Ai(ij)*(ne(ij,right)*grad_e(ij+u_right,l)*le(ij+u_right)  +  &
-                             ne(ij,rup)*grad_e(ij+u_rup,l)*le(ij+u_rup)              +  &
-                             ne(ij,lup)*grad_e(ij+u_lup,l)*le(ij+u_lup)              +  &
-                             ne(ij,left)*grad_e(ij+u_left,l)*le(ij+u_left)           +  &
-                             ne(ij,ldown)*grad_e(ij+u_ldown,l)*le(ij+u_ldown)        +  & 
-                             ne(ij,rdown)*grad_e(ij+u_rdown,l)*le(ij+u_rdown))
-      ENDDO
-    ENDDO
-   
-    DO l=llb,lle
-      DO ij=ij_begin,ij_end
-          theta_divgrad_i(ij,l)=-theta_divgrad_i(ij,l)*cdivgrad
-      ENDDO
-    ENDDO
-  END SUBROUTINE compute_divgrad_inplace
-
-  SUBROUTINE compute_gradrot(ue,gradrot_e,llb,lle)
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(IN) :: ue(iim*3*jjm,lle)
-    REAL(rstd),INTENT(OUT) :: gradrot_e(iim*3*jjm,lle)
-    
-    gradrot_e = ue
-    CALL compute_gradrot_inplace(gradrot_e,llb,lle)
-  END SUBROUTINE
-    
-  SUBROUTINE compute_gradrot_inplace(ue_gradrot_e,llb,lle)
-  USE icosa
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)     :: llb
-    INTEGER,INTENT(IN)     :: lle
-    REAL(rstd),INTENT(INOUT) :: ue_gradrot_e(iim*3*jjm,lle)
-    REAL(rstd) :: rot_v(2*iim*jjm,llb:lle)
-
-    INTEGER :: ij,l
-
-    DO l=llb,lle
-!DIR$ SIMD
-      DO ij=ij_begin_ext,ij_end_ext        
-          rot_v(ij+z_up,l)= 1./Av(ij+z_up)*(  ne(ij,rup)*ue_gradrot_e(ij+u_rup,l)*de(ij+u_rup) &
-                                + ne(ij+t_rup,left)*ue_gradrot_e(ij+t_rup+u_left,l)*de(ij+t_rup+u_left) &
-                                - ne(ij,lup)*ue_gradrot_e(ij+u_lup,l)*de(ij+u_lup) )                               
-          rot_v(ij+z_down,l) = 1./Av(ij+z_down)*( ne(ij,ldown)*ue_gradrot_e(ij+u_ldown,l)*de(ij+u_ldown) &
-                                     + ne(ij+t_ldown,right)*ue_gradrot_e(ij+t_ldown+u_right,l)*de(ij+t_ldown+u_right) &
-                                     - ne(ij,rdown)*ue_gradrot_e(ij+u_rdown,l)*de(ij+u_rdown) )
-      ENDDO
-    ENDDO                              
-  
-    DO l=llb,lle
-!DIR$ SIMD
-      DO ij=ij_begin,ij_end
-          ue_gradrot_e(ij+u_right,l)=1/le(ij+u_right)*ne(ij,right)*(rot_v(ij+z_rdown,l)-rot_v(ij+z_rup,l))       
-          ue_gradrot_e(ij+u_lup,l)=1/le(ij+u_lup)*ne(ij,lup)*(rot_v(ij+z_up,l)-rot_v(ij+z_lup,l))        
-          ue_gradrot_e(ij+u_ldown,l)=1/le(ij+u_ldown)*ne(ij,ldown)*(rot_v(ij+z_ldown,l)-rot_v(ij+z_down,l))
-      ENDDO
-    ENDDO
-
-    DO l=llb,lle
-!DIR$ SIMD
-      DO ij=ij_begin,ij_end    
-          ue_gradrot_e(ij+u_right,l)=-ue_gradrot_e(ij+u_right,l)*cgradrot       
-          ue_gradrot_e(ij+u_lup,l)=-ue_gradrot_e(ij+u_lup,l)*cgradrot
-          ue_gradrot_e(ij+u_ldown,l)=-ue_gradrot_e(ij+u_ldown,l)*cgradrot        
-      ENDDO
-    ENDDO  
-  END SUBROUTINE compute_gradrot_inplace
-
-
-END MODULE dissip_gcm_mod
-       
Index: codes/icosagcm/trunk/src/dissip/sponge.f90
===================================================================
--- codes/icosagcm/trunk/src/dissip/sponge.f90	(revision 926)
+++ codes/icosagcm/trunk/src/dissip/sponge.f90	(revision 953)
@@ -24,4 +24,5 @@
   USE omp_para
   USE mpipara, ONLY: is_mpi_master
+  USE abort_mod
   IMPLICIT NONE
     INTEGER :: l
@@ -43,4 +44,8 @@
       RETURN
     ENDIF
+
+    IF (iflag_sponge > 0) THEN
+       CALL abort_acc("iflag_sponge > 0")
+    END IF
 
 !$OMP MASTER
Index: codes/icosagcm/trunk/src/dynamics/caldyn_gcm.F90
===================================================================
--- codes/icosagcm/trunk/src/dynamics/caldyn_gcm.F90	(revision 926)
+++ codes/icosagcm/trunk/src/dynamics/caldyn_gcm.F90	(revision 953)
@@ -15,4 +15,5 @@
   
   SUBROUTINE init_caldyn
+    USE abort_mod
     CHARACTER(len=255) :: def
     INTEGER            :: ind
@@ -21,5 +22,9 @@
     hydrostatic=.TRUE.
     CALL getin("hydrostatic",hydrostatic)
-  
+
+    IF (.NOT. hydrostatic) THEN
+       CALL abort_acc("hydrostatic /= .TRUE.")
+    END IF
+
     dysl=.NOT.hydrostatic ! dysl defaults to .FALSE. if hydrostatic, .TRUE. if NH                                              
     CALL getin("dysl",dysl)
@@ -34,4 +39,9 @@
     dysl_caldyn_coriolis=dysl
     CALL getin("dysl_caldyn_coriolis",dysl_caldyn_coriolis)
+
+    ! dysl is not supported with openACC
+    IF (dysl_geopot .OR. dysl_caldyn_fast .OR. dysl_slow_hydro .OR. dysl_pvort_only .OR. dysl_caldyn_coriolis) THEN
+       CALL abort_acc("dysl not supported")
+    END IF
 
     def='energy'
@@ -122,8 +132,8 @@
   SUBROUTINE allocate_caldyn
     CALL allocate_field(f_out_u,field_u,type_real,llm) 
-    CALL allocate_field(f_qu,field_u,type_real,llm) 
-    CALL allocate_field(f_qv,field_z,type_real,llm) 
-    CALL allocate_field(f_pk,    field_t,type_real,llm,  name='pk')
-    CALL allocate_field(f_wwuu,  field_u,type_real,llm+1,name='wwuu')    
+    CALL allocate_field(f_qu,field_u,type_real,llm, ondevice=.TRUE.) 
+    CALL allocate_field(f_qv,field_z,type_real,llm, ondevice=.TRUE.) 
+    CALL allocate_field(f_pk,    field_t,type_real,llm,  name='pk', ondevice=.TRUE.)
+    CALL allocate_field(f_wwuu,  field_u,type_real,llm+1,name='wwuu', ondevice=.TRUE.)    
     CALL allocate_field(f_planetvel,  field_u,type_real, name='planetvel') ! planetary velocity at r=a
     IF(.NOT.hydrostatic) THEN
Index: codes/icosagcm/trunk/src/dynamics/caldyn_hevi.F90
===================================================================
--- codes/icosagcm/trunk/src/dynamics/caldyn_hevi.F90	(revision 953)
+++ codes/icosagcm/trunk/src/dynamics/caldyn_hevi.F90	(revision 953)
@@ -0,0 +1,201 @@
+MODULE caldyn_hevi_mod
+  USE icosa
+  USE transfert_mod
+  USE caldyn_kernels_base_mod
+  USE caldyn_kernels_hevi_mod
+  USE caldyn_gcm_mod
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC caldyn_hevi
+
+CONTAINS
+  
+  SUBROUTINE caldyn_hevi(write_out,tau, f_phis, f_ps, f_mass, f_theta_rhodz, f_u, f_q, &
+       f_W, f_geopot, f_hflux, f_wflux, f_dps, f_dmass, f_dtheta_rhodz, &
+       f_du_slow, f_du_fast, f_dPhi_slow, f_dPhi_fast, f_dW_slow, f_dW_fast) 
+    USE icosa
+    USE observable_mod
+    USE disvert_mod, ONLY : caldyn_eta, eta_mass
+    USE vorticity_mod
+    USE kinetic_mod
+    USE theta2theta_rhodz_mod
+    USE wind_mod
+    USE mpipara
+    USE trace
+    USE omp_para
+    USE output_field_mod
+    USE checksum_mod
+    USE abort_mod
+    IMPLICIT NONE
+    LOGICAL,INTENT(IN)    :: write_out
+    REAL(rstd), INTENT(IN) :: tau
+    TYPE(t_field),POINTER :: f_phis(:)
+    TYPE(t_field),POINTER :: f_ps(:)
+    TYPE(t_field),POINTER :: f_mass(:)
+    TYPE(t_field),POINTER :: f_theta_rhodz(:)
+    TYPE(t_field),POINTER :: f_u(:)
+    TYPE(t_field),POINTER :: f_q(:)
+    TYPE(t_field),POINTER :: f_W(:)
+    TYPE(t_field),POINTER :: f_geopot(:)
+    TYPE(t_field),POINTER :: f_hflux(:), f_wflux(:)
+    TYPE(t_field) :: f_dps(:)
+    TYPE(t_field) :: f_dmass(:)
+    TYPE(t_field) :: f_dtheta_rhodz(:)
+    TYPE(t_field) :: f_du_slow(:)
+    TYPE(t_field) :: f_du_fast(:)
+    TYPE(t_field) :: f_dW_slow(:)
+    TYPE(t_field) :: f_dW_fast(:)
+    TYPE(t_field) :: f_dPhi_slow(:)
+    TYPE(t_field) :: f_dPhi_fast(:)
+    
+    REAL(rstd),POINTER :: ps(:), dps(:), phis(:)
+    REAL(rstd),POINTER :: mass(:,:), theta_rhodz(:,:,:), dtheta_rhodz(:,:,:)
+    REAL(rstd),POINTER :: du(:,:), dW(:,:), dPhi(:,:), hflux(:,:), wflux(:,:)
+    REAL(rstd),POINTER :: u(:,:), w(:,:), qu(:,:), qv(:,:)
+
+! temporary shared variable
+    REAL(rstd),POINTER  :: theta(:,:,:)  
+    REAL(rstd),POINTER  :: pk(:,:)
+    REAL(rstd),POINTER  :: geopot(:,:)
+    REAL(rstd),POINTER  :: convm(:,:) 
+    REAL(rstd),POINTER  :: wwuu(:,:)
+    REAL(rstd),POINTER  :: F_el(:,:), gradPhi2(:,:), w_il(:,:) , W_etadot(:,:), pres(:,:), m_il(:,:)
+    INTEGER :: ind
+    LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    
+    IF (first) THEN 
+      first=.FALSE.
+      IF(caldyn_eta==eta_mass) THEN
+         CALL init_message(f_ps,req_i1,req_ps)
+      ELSE
+         CALL init_message(f_mass,req_i1,req_mass)
+      END IF
+      CALL init_message(f_theta_rhodz,req_i1,req_theta_rhodz)
+      CALL init_message(f_u,req_e1_vect,req_u)
+      CALL init_message(f_qu,req_e1_scal,req_qu)
+      IF(.NOT.hydrostatic) THEN
+         CALL init_message(f_geopot,req_i1,req_geopot)
+         CALL init_message(f_w,req_i1,req_w)
+      END IF
+    ENDIF
+    
+    CALL trace_start("caldyn")
+    
+    IF(caldyn_eta==eta_mass) THEN
+       CALL send_message(f_ps,req_ps) ! COM00
+       CALL wait_message(req_ps) ! COM00
+    ELSE
+       CALL abort_acc("HEVI_scheme/!eta_mass")
+       CALL send_message(f_mass,req_mass) ! COM00
+       CALL wait_message(req_mass) ! COM00
+    END IF
+    CALL send_message(f_theta_rhodz,req_theta_rhodz) ! COM01
+    CALL wait_message(req_theta_rhodz) ! COM01 Moved from caldyn_pvort
+
+    IF(.NOT.hydrostatic) THEN
+       CALL abort_acc("HEVI_scheme/!hydrostatic")
+       CALL send_message(f_geopot,req_geopot) ! COM03
+       CALL wait_message(req_geopot) ! COM03
+       CALL send_message(f_w,req_w) ! COM04
+       CALL wait_message(req_w) ! COM04
+    END IF
+    
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       ps=f_ps(ind)
+       theta_rhodz=f_theta_rhodz(ind)
+       mass=f_mass(ind)
+       theta = f_theta(ind)
+       CALL compute_theta(ps,theta_rhodz, mass,theta)
+       pk = f_pk(ind)
+       geopot = f_geopot(ind)
+       du=f_du_fast(ind)
+       IF(hydrostatic) THEN
+          !$acc kernels present(du) async
+          du(:,:)=0.0d0
+          !$acc end kernels
+          CALL compute_geopot(mass,theta, ps,pk,geopot)
+       ELSE
+          CALL abort_acc("HEVI_scheme/!hydrostatic")
+          phis = f_phis(ind)
+          W = f_W(ind)
+          dW = f_dW_fast(ind)
+          dPhi = f_dPhi_fast(ind)
+          ! reuse buffers
+          m_il = f_wil(ind)
+          pres = f_gradPhi2(ind)
+          CALL compute_caldyn_solver(tau,phis, mass,theta,pk,geopot,W, m_il,pres, dPhi,dW,du) ! computes d(Phi,W,du)_fast and updates Phi,W
+       END IF
+       u=f_u(ind)
+       CALL compute_caldyn_fast(tau,u,mass,theta,pk,geopot,du) ! computes du_fast and updates u
+    ENDDO
+    
+    CALL send_message(f_u,req_u) ! COM02
+    CALL wait_message(req_u)   ! COM02
+    
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       u=f_u(ind)
+       mass=f_mass(ind)
+       qu=f_qu(ind)
+       qv=f_qv(ind)
+       CALL compute_pvort_only(u,mass,qu,qv)
+    ENDDO
+    
+    CALL send_message(f_qu,req_qu) ! COM03
+    CALL wait_message(req_qu) ! COM03
+       
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       u=f_u(ind)
+       mass=f_mass(ind)
+       theta = f_theta(ind)
+       qu=f_qu(ind)
+       hflux=f_hflux(ind)
+       convm = f_dmass(ind)
+       dtheta_rhodz=f_dtheta_rhodz(ind)
+       du=f_du_slow(ind)
+
+       IF(hydrostatic) THEN
+          CALL compute_caldyn_slow_hydro(u,mass,hflux,du, .TRUE.)
+       ELSE
+          CALL abort_acc("HEVI_scheme/!hydrostatic")
+          W = f_W(ind)
+          dW = f_dW_slow(ind)
+          geopot = f_geopot(ind)
+          dPhi = f_dPhi_slow(ind)
+          F_el = f_Fel(ind)
+          gradPhi2 = f_gradPhi2(ind)
+          w_il = f_wil(ind)
+          CALL compute_caldyn_slow_NH(u,mass,geopot,W, F_el,gradPhi2,w_il, hflux,du,dPhi,dW)
+       END IF
+       CALL compute_caldyn_Coriolis(hflux,theta,qu,convm,dtheta_rhodz,du)
+       
+       IF(caldyn_eta==eta_mass) THEN
+          wflux=f_wflux(ind)
+          wwuu=f_wwuu(ind)
+          dps=f_dps(ind)
+          CALL compute_caldyn_vert(u,theta,mass,convm, wflux,wwuu, dps, dtheta_rhodz, du)
+          IF(.NOT.hydrostatic) THEN
+             CALL abort_acc("HEVI_scheme/!hydrostatic")
+             W_etadot=f_Wetadot(ind)
+             CALL compute_caldyn_vert_NH(mass,geopot,W,wflux, W_etadot, du,dPhi,dW)
+          END IF
+       END IF
+    ENDDO
+    
+!$OMP BARRIER
+    !    CALL check_mass_conservation(f_ps,f_dps)
+    CALL trace_end("caldyn_hevi")
+!!$OMP BARRIER
+    
+  END SUBROUTINE caldyn_hevi
+
+END MODULE caldyn_hevi_mod
Index: codes/icosagcm/trunk/src/dynamics/caldyn_hevi.f90
===================================================================
--- codes/icosagcm/trunk/src/dynamics/caldyn_hevi.f90	(revision 926)
+++ 	(revision )
@@ -1,192 +1,0 @@
-MODULE caldyn_hevi_mod
-  USE icosa
-  USE transfert_mod
-  USE caldyn_kernels_base_mod
-  USE caldyn_kernels_hevi_mod
-  USE caldyn_gcm_mod
-  IMPLICIT NONE
-  PRIVATE
-  PUBLIC caldyn_hevi
-
-CONTAINS
-  
-  SUBROUTINE caldyn_hevi(write_out,tau, f_phis, f_ps, f_mass, f_theta_rhodz, f_u, f_q, &
-       f_W, f_geopot, f_hflux, f_wflux, f_dps, f_dmass, f_dtheta_rhodz, &
-       f_du_slow, f_du_fast, f_dPhi_slow, f_dPhi_fast, f_dW_slow, f_dW_fast) 
-    USE icosa
-    USE observable_mod
-    USE disvert_mod, ONLY : caldyn_eta, eta_mass
-    USE vorticity_mod
-    USE kinetic_mod
-    USE theta2theta_rhodz_mod
-    USE wind_mod
-    USE mpipara
-    USE trace
-    USE omp_para
-    USE output_field_mod
-    USE checksum_mod
-    IMPLICIT NONE
-    LOGICAL,INTENT(IN)    :: write_out
-    REAL(rstd), INTENT(IN) :: tau
-    TYPE(t_field),POINTER :: f_phis(:)
-    TYPE(t_field),POINTER :: f_ps(:)
-    TYPE(t_field),POINTER :: f_mass(:)
-    TYPE(t_field),POINTER :: f_theta_rhodz(:)
-    TYPE(t_field),POINTER :: f_u(:)
-    TYPE(t_field),POINTER :: f_q(:)
-    TYPE(t_field),POINTER :: f_W(:)
-    TYPE(t_field),POINTER :: f_geopot(:)
-    TYPE(t_field),POINTER :: f_hflux(:), f_wflux(:)
-    TYPE(t_field) :: f_dps(:)
-    TYPE(t_field) :: f_dmass(:)
-    TYPE(t_field) :: f_dtheta_rhodz(:)
-    TYPE(t_field) :: f_du_slow(:)
-    TYPE(t_field) :: f_du_fast(:)
-    TYPE(t_field) :: f_dW_slow(:)
-    TYPE(t_field) :: f_dW_fast(:)
-    TYPE(t_field) :: f_dPhi_slow(:)
-    TYPE(t_field) :: f_dPhi_fast(:)
-    
-    REAL(rstd),POINTER :: ps(:), dps(:), phis(:)
-    REAL(rstd),POINTER :: mass(:,:), theta_rhodz(:,:,:), dtheta_rhodz(:,:,:)
-    REAL(rstd),POINTER :: du(:,:), dW(:,:), dPhi(:,:), hflux(:,:), wflux(:,:)
-    REAL(rstd),POINTER :: u(:,:), w(:,:), qu(:,:), qv(:,:)
-
-! temporary shared variable
-    REAL(rstd),POINTER  :: theta(:,:,:)  
-    REAL(rstd),POINTER  :: pk(:,:)
-    REAL(rstd),POINTER  :: geopot(:,:)
-    REAL(rstd),POINTER  :: convm(:,:) 
-    REAL(rstd),POINTER  :: wwuu(:,:)
-    REAL(rstd),POINTER  :: F_el(:,:), gradPhi2(:,:), w_il(:,:) , W_etadot(:,:), pres(:,:), m_il(:,:)
-    INTEGER :: ind
-    LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-    
-    IF (first) THEN 
-      first=.FALSE.
-      IF(caldyn_eta==eta_mass) THEN
-         CALL init_message(f_ps,req_i1,req_ps)
-      ELSE
-         CALL init_message(f_mass,req_i1,req_mass)
-      END IF
-      CALL init_message(f_theta_rhodz,req_i1,req_theta_rhodz)
-      CALL init_message(f_u,req_e1_vect,req_u)
-      CALL init_message(f_qu,req_e1_scal,req_qu)
-      IF(.NOT.hydrostatic) THEN
-         CALL init_message(f_geopot,req_i1,req_geopot)
-         CALL init_message(f_w,req_i1,req_w)
-      END IF
-    ENDIF
-    
-    CALL trace_start("caldyn")
-    
-    IF(caldyn_eta==eta_mass) THEN
-       CALL send_message(f_ps,req_ps) ! COM00
-       CALL wait_message(req_ps) ! COM00
-    ELSE
-       CALL send_message(f_mass,req_mass) ! COM00
-       CALL wait_message(req_mass) ! COM00
-    END IF
-    CALL send_message(f_theta_rhodz,req_theta_rhodz) ! COM01
-    CALL wait_message(req_theta_rhodz) ! COM01 Moved from caldyn_pvort
-
-    IF(.NOT.hydrostatic) THEN
-       CALL send_message(f_geopot,req_geopot) ! COM03
-       CALL wait_message(req_geopot) ! COM03
-       CALL send_message(f_w,req_w) ! COM04
-       CALL wait_message(req_w) ! COM04
-    END IF
-    
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       ps=f_ps(ind)
-       theta_rhodz=f_theta_rhodz(ind)
-       mass=f_mass(ind)
-       theta = f_theta(ind)
-       CALL compute_theta(ps,theta_rhodz, mass,theta)
-       pk = f_pk(ind)
-       geopot = f_geopot(ind)
-       du=f_du_fast(ind)
-       IF(hydrostatic) THEN
-          du(:,:)=0.
-          CALL compute_geopot(mass,theta, ps,pk,geopot)
-       ELSE
-          phis = f_phis(ind)
-          W = f_W(ind)
-          dW = f_dW_fast(ind)
-          dPhi = f_dPhi_fast(ind)
-          ! reuse buffers
-          m_il = f_wil(ind)
-          pres = f_gradPhi2(ind)
-          CALL compute_caldyn_solver(tau,phis, mass,theta,pk,geopot,W, m_il,pres, dPhi,dW,du) ! computes d(Phi,W,du)_fast and updates Phi,W
-       END IF
-       u=f_u(ind)
-       CALL compute_caldyn_fast(tau,u,mass,theta,pk,geopot,du) ! computes du_fast and updates u
-    ENDDO
-    
-    CALL send_message(f_u,req_u) ! COM02
-    CALL wait_message(req_u)   ! COM02
-    
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       u=f_u(ind)
-       mass=f_mass(ind)
-       qu=f_qu(ind)
-       qv=f_qv(ind)
-       CALL compute_pvort_only(u,mass,qu,qv)
-    ENDDO
-    
-    CALL send_message(f_qu,req_qu) ! COM03
-    CALL wait_message(req_qu) ! COM03
-       
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       u=f_u(ind)
-       mass=f_mass(ind)
-       theta = f_theta(ind)
-       qu=f_qu(ind)
-       hflux=f_hflux(ind)
-       convm = f_dmass(ind)
-       dtheta_rhodz=f_dtheta_rhodz(ind)
-       du=f_du_slow(ind)
-
-       IF(hydrostatic) THEN
-          CALL compute_caldyn_slow_hydro(u,mass,hflux,du, .TRUE.)
-       ELSE
-          W = f_W(ind)
-          dW = f_dW_slow(ind)
-          geopot = f_geopot(ind)
-          dPhi = f_dPhi_slow(ind)
-          F_el = f_Fel(ind)
-          gradPhi2 = f_gradPhi2(ind)
-          w_il = f_wil(ind)
-          CALL compute_caldyn_slow_NH(u,mass,geopot,W, F_el,gradPhi2,w_il, hflux,du,dPhi,dW)
-       END IF
-       CALL compute_caldyn_Coriolis(hflux,theta,qu, convm,dtheta_rhodz,du)
-       IF(caldyn_eta==eta_mass) THEN
-          wflux=f_wflux(ind)
-          wwuu=f_wwuu(ind)
-          dps=f_dps(ind)
-          CALL compute_caldyn_vert(u,theta,mass,convm, wflux,wwuu, dps, dtheta_rhodz, du)
-          IF(.NOT.hydrostatic) THEN
-             W_etadot=f_Wetadot(ind)
-             CALL compute_caldyn_vert_NH(mass,geopot,W,wflux, W_etadot, du,dPhi,dW)
-          END IF
-       END IF
-    ENDDO
-    
-!$OMP BARRIER
-    !    CALL check_mass_conservation(f_ps,f_dps)
-    CALL trace_end("caldyn_hevi")
-!!$OMP BARRIER
-    
-  END SUBROUTINE caldyn_hevi
-
-END MODULE caldyn_hevi_mod
Index: codes/icosagcm/trunk/src/dynamics/caldyn_kernels_base.F90
===================================================================
--- codes/icosagcm/trunk/src/dynamics/caldyn_kernels_base.F90	(revision 926)
+++ codes/icosagcm/trunk/src/dynamics/caldyn_kernels_base.F90	(revision 953)
@@ -5,4 +5,5 @@
   USE omp_para
   USE trace
+  USE abort_mod
   IMPLICIT NONE
   PRIVATE
@@ -25,5 +26,4 @@
 
   !**************************** Geopotential *****************************
-
   SUBROUTINE compute_geopot(rhodz,theta, ps,pk,geopot) 
     REAL(rstd),INTENT(IN)    :: rhodz(iim*jjm,llm)
@@ -46,4 +46,5 @@
 
     IF(dysl_geopot) THEN
+      CALL abort_acc("HEVI_scheme/!dysl_geopot")
 #include "../kernels/compute_geopot.k90"
     ELSE
@@ -52,26 +53,35 @@
     ! Works also when caldyn_eta=eta_mass          
 
+    !$acc data present(rhodz(:,:), ps(:), pk(:,:), geopot(:,:), theta(:,:,:)) async
+
     IF(boussinesq) THEN ! compute geopotential and pk=Lagrange multiplier
+       CALL abort_acc("HEVI_scheme/boussinesq")
        ! specific volume 1 = dphi/g/rhodz
        !         IF (is_omp_level_master) THEN ! no openMP on vertical due to dependency
        DO l = 1,llm
+          !$acc parallel loop
           !DIR$ SIMD
           DO ij=ij_omp_begin_ext,ij_omp_end_ext         
              geopot(ij,l+1) = geopot(ij,l) + g*rhodz(ij,l)
           ENDDO
+          !$acc end parallel loop
        ENDDO
        ! use hydrostatic balance with theta*rhodz to find pk (Lagrange multiplier=pressure) 
        ! uppermost layer
+       !$acc parallel loop
        !DIR$ SIMD
        DO ij=ij_begin_ext,ij_end_ext         
           pk(ij,llm) = ptop + (.5*g)*theta(ij,llm,1)*rhodz(ij,llm)
        END DO
+       !$acc end parallel loop
        ! other layers
        DO l = llm-1, 1, -1
           !          !$OMP DO SCHEDULE(STATIC) 
+          !$acc parallel loop
           !DIR$ SIMD
           DO ij=ij_begin_ext,ij_end_ext         
              pk(ij,l) = pk(ij,l+1) + (.5*g)*(theta(ij,l,1)*rhodz(ij,l)+theta(ij,l+1,1)*rhodz(ij,l+1))
           END DO
+          !$acc end parallel loop
        END DO
        ! now pk contains the Lagrange multiplier (pressure)
@@ -81,9 +91,15 @@
        SELECT CASE(caldyn_thermo)
           CASE(thermo_theta, thermo_entropy)
+             !$acc parallel loop async
              !DIR$ SIMD
              DO ij=ij_omp_begin_ext,ij_omp_end_ext
                 pk(ij,llm) = ptop + (.5*g)*rhodz(ij,llm)
              END DO
+
              ! other layers
+             ! We use kernels here instead of "loop seq" + "loop gang vector"
+             ! to be sure the code really abides the standard. In practice,
+             ! it seems like the compiler interchanges the loops.
+             !$acc kernels async
              DO l = llm-1, 1, -1
                 !DIR$ SIMD
@@ -92,6 +108,8 @@
                 END DO
              END DO
+             !$acc end kernels
              ! surface pressure (for diagnostics)
              IF(caldyn_eta==eta_lag) THEN
+                !$acc parallel loop async
                 DO ij=ij_omp_begin_ext,ij_omp_end_ext         
                    ps(ij) = pk(ij,1) + (.5*g)*rhodz(ij,1)
@@ -99,10 +117,15 @@
              END IF
           CASE(thermo_moist) ! theta(ij,l,2) = qv = mv/md
+             CALL abort_acc("HEVI_scheme/thermo_moist")
+             !$acc parallel loop
              !DIR$ SIMD
              DO ij=ij_omp_begin_ext,ij_omp_end_ext
                 pk(ij,llm) = ptop + (.5*g)*rhodz(ij,llm)*(1.+theta(ij,l,2))
              END DO
+             !$acc end parallel loop
+
              ! other layers
              DO l = llm-1, 1, -1
+                !$acc parallel loop
                 !DIR$ SIMD
                 DO ij=ij_omp_begin_ext,ij_omp_end_ext         
@@ -111,51 +134,70 @@
                         rhodz(ij,l+1)*(1.+theta(ij,l+1,2)) )
                 END DO
+                !$acc end parallel loop
              END DO
              ! surface pressure (for diagnostics)
              IF(caldyn_eta==eta_lag) THEN
+                !$acc parallel loop
                 DO ij=ij_omp_begin_ext,ij_omp_end_ext         
                    ps(ij) = pk(ij,1) + (.5*g)*rhodz(ij,1)*(1.+theta(ij,l,2))
                 END DO
+                !$acc end parallel loop
              END IF
           END SELECT
 
-       DO l = 1,llm
-          SELECT CASE(caldyn_thermo)
+        SELECT CASE(caldyn_thermo)
           CASE(thermo_theta)
-             !DIR$ SIMD
-             DO ij=ij_omp_begin_ext,ij_omp_end_ext
-                p_ik = pk(ij,l)
-                exner_ik = cpp * (p_ik/preff) ** kappa
-                pk(ij,l) = exner_ik
-                ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz
-                geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l,1)*exner_ik/p_ik
-             ENDDO
+            ! We use kernels here instead of "loop seq" + "loop gang vector"
+            ! to be sure the code really abides the standard. In practice,
+            ! it seems like the compiler interchanges the loops.
+            !$acc kernels async
+            DO l = 1,llm
+               !DIR$ SIMD
+               DO ij=ij_omp_begin_ext,ij_omp_end_ext
+                  p_ik = pk(ij,l)
+                  exner_ik = cpp * (p_ik/preff) ** kappa
+                  pk(ij,l) = exner_ik
+                  ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz
+                  geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l,1)*exner_ik/p_ik
+               ENDDO
+            ENDDO
+            !$acc end kernels
+
           CASE(thermo_entropy) ! theta is in fact entropy = cpp*log(theta/Treff) = cpp*log(T/Treff) - Rd*log(p/preff)
-             !DIR$ SIMD
-             DO ij=ij_omp_begin_ext,ij_omp_end_ext
-                p_ik = pk(ij,l)
-                temp_ik = Treff*exp((theta(ij,l,1) + Rd*log(p_ik/preff))/cpp)
-                pk(ij,l) = temp_ik
-                ! specific volume v = Rd*T/p = dphi/g/rhodz
-                geopot(ij,l+1) = geopot(ij,l) + (g*Rd)*rhodz(ij,l)*temp_ik/p_ik
+             CALL abort_acc("HEVI_scheme/thermo_entropy")
+             DO l = 1,llm
+               !$acc parallel loop
+               !DIR$ SIMD
+               DO ij=ij_omp_begin_ext,ij_omp_end_ext
+                  p_ik = pk(ij,l)
+                  temp_ik = Treff*exp((theta(ij,l,1) + Rd*log(p_ik/preff))/cpp)
+                  pk(ij,l) = temp_ik
+                  ! specific volume v = Rd*T/p = dphi/g/rhodz
+                  geopot(ij,l+1) = geopot(ij,l) + (g*Rd)*rhodz(ij,l)*temp_ik/p_ik
+               ENDDO
+               !$acc end parallel loop
              ENDDO
           CASE(thermo_moist) ! theta is moist pseudo-entropy per dry air mass
-             DO ij=ij_omp_begin_ext,ij_omp_end_ext
-                p_ik = pk(ij,l)
-                qv = theta(ij,l,2) ! water vaper mixing ratio = mv/md
-                Rmix = Rd+qv*Rv
-                chi = ( theta(ij,l,1) + Rmix*log(p_ik/preff) ) / (cpp + qv*cppv) ! log(T/Treff)
-                temp_ik = Treff*exp(chi)
-                pk(ij,l) = temp_ik
-                ! specific volume v = R*T/p = dphi/g/rhodz
-                ! R = (Rd + qv.Rv)/(1+qv)
-                geopot(ij,l+1) = geopot(ij,l) + g*Rmix*rhodz(ij,l)*temp_ik/(p_ik*(1+qv))
+             CALL abort_acc("HEVI_scheme/thermo_moist")
+             DO l = 1,llm
+               !$acc parallel loop
+               DO ij=ij_omp_begin_ext,ij_omp_end_ext
+                  p_ik = pk(ij,l)
+                  qv = theta(ij,l,2) ! water vaper mixing ratio = mv/md
+                  Rmix = Rd+qv*Rv
+                  chi = ( theta(ij,l,1) + Rmix*log(p_ik/preff) ) / (cpp + qv*cppv) ! log(T/Treff)
+                  temp_ik = Treff*exp(chi)
+                  pk(ij,l) = temp_ik
+                  ! specific volume v = R*T/p = dphi/g/rhodz
+                  ! R = (Rd + qv.Rv)/(1+qv)
+                  geopot(ij,l+1) = geopot(ij,l) + g*Rmix*rhodz(ij,l)*temp_ik/(p_ik*(1+qv))
+               ENDDO
+               !$acc end parallel loop
              ENDDO
           CASE DEFAULT
              STOP
-          END SELECT
-       ENDDO
+        END SELECT
     END IF
-
+    !$acc end data
     END IF ! dysl
 
@@ -167,5 +209,6 @@
   END SUBROUTINE compute_geopot
 
-  SUBROUTINE compute_caldyn_vert(u,theta,rhodz,convm, wflux,wwuu, dps,dtheta_rhodz,du)
+  SUBROUTINE compute_caldyn_vert(u, theta, rhodz, convm, wflux, wwuu, dps, dtheta_rhodz, du)
+    USE disvert_mod, ONLY : bp
     REAL(rstd),INTENT(IN)  :: u(iim*3*jjm,llm)
     REAL(rstd),INTENT(IN)  :: theta(iim*jjm,llm,nqdyn)
@@ -193,7 +236,15 @@
     CALL trace_start("compute_caldyn_vert")
 
+    !$acc data async &
+    !$acc present(rhodz(:,:), u(:,:), wwuu(:,:), wflux(:,:), dps(:), convm(:,:), du(:,:), dtheta_rhodz(:,:,:), theta(:,:,:), bp(:))
+
+
     !$OMP BARRIER   
 !!! cumulate mass flux convergence from top to bottom
     !  IF (is_omp_level_master) THEN
+    ! We use kernels here instead of "loop seq" + "loop gang vector"
+    ! to be sure the code really abides the standard. In practice,
+    ! it seems like the compiler interchanges the loops.
+    !$acc kernels async
     DO  l = llm-1, 1, -1
        !    IF (caldyn_conserv==energy) CALL test_message(req_qu) 
@@ -205,4 +256,5 @@
        ENDDO
     ENDDO
+    !$acc end kernels
     !  ENDIF
 
@@ -213,4 +265,5 @@
     ! compute dps
     IF (is_omp_first_level) THEN
+       !$acc parallel loop  async
        !DIR$ SIMD
        DO ij=ij_begin,ij_end         
@@ -221,4 +274,5 @@
 
 !!! Compute vertical mass flux (l=1,llm+1 done by caldyn_BC)
+    !$acc parallel loop collapse(2) async
     DO l=ll_beginp1,ll_end
        !    IF (caldyn_conserv==energy) CALL test_message(req_qu) 
@@ -233,5 +287,5 @@
     !--> flush wflux  
     !$OMP BARRIER
-
+    !$acc parallel loop collapse(3) async
     DO iq=1,nqdyn
        DO l=ll_begin,ll_endm1
@@ -242,4 +296,8 @@
           END DO
        END DO
+    END DO
+    
+    !$acc parallel loop collapse(3) async
+    DO iq=1,nqdyn
        DO l=ll_beginp1,ll_end
           !DIR$ SIMD
@@ -252,4 +310,5 @@
 
     ! Compute vertical transport
+    !$acc parallel loop collapse(2) async
     DO l=ll_beginp1,ll_end
        !DIR$ SIMD
@@ -265,4 +324,5 @@
 
     ! Add vertical transport to du
+    !$acc parallel loop collapse(2) async
     DO l=ll_begin,ll_end
        !DIR$ SIMD
@@ -283,4 +343,5 @@
     !   ENDDO
 
+    !$acc end data
     CALL trace_end("compute_caldyn_vert")
 
Index: codes/icosagcm/trunk/src/dynamics/caldyn_kernels_hevi.F90
===================================================================
--- codes/icosagcm/trunk/src/dynamics/caldyn_kernels_hevi.F90	(revision 926)
+++ codes/icosagcm/trunk/src/dynamics/caldyn_kernels_hevi.F90	(revision 953)
@@ -6,4 +6,5 @@
   USE transfert_mod
   USE caldyn_kernels_base_mod
+  USE abort_mod
   IMPLICIT NONE
   PRIVATE
@@ -20,4 +21,5 @@
 
   SUBROUTINE compute_theta(ps,theta_rhodz, rhodz,theta)
+    USE disvert_mod, ONLY : mass_dbk, mass_dak
     REAL(rstd),INTENT(IN)    :: ps(iim*jjm)
     REAL(rstd),INTENT(IN)    :: theta_rhodz(iim*jjm,llm,nqdyn)
@@ -26,7 +28,12 @@
     INTEGER :: ij,l,iq
     REAL(rstd) :: m
+
     CALL trace_start("compute_theta")
 
+    !$acc data async &
+    !$acc present(ps(:), theta_rhodz(:,:,:), rhodz(:,:), theta(:,:,:), mass_dak(:), mass_dbk(:))
+
     IF(caldyn_eta==eta_mass) THEN ! Compute mass
+       !$acc parallel loop collapse(2) async
        DO l = ll_begin,ll_end
           !DIR$ SIMD
@@ -38,6 +45,7 @@
     END IF
 
-    DO l = ll_begin,ll_end
-       DO iq=1,nqdyn
+    !$acc parallel loop collapse(3) async
+    DO iq=1,nqdyn
+       DO l = ll_begin,ll_end
           !DIR$ SIMD
           DO ij=ij_begin_ext,ij_end_ext
@@ -47,8 +55,10 @@
     END DO
 
+    !$acc end data
     CALL trace_end("compute_theta")
   END SUBROUTINE compute_theta
 
   SUBROUTINE compute_pvort_only(u,rhodz,qu,qv)
+    USE geometry, ONLY : Av, Riv2, fv
     REAL(rstd),INTENT(IN)  :: u(iim*3*jjm,llm)
     REAL(rstd),INTENT(INOUT) :: rhodz(iim*jjm,llm)
@@ -61,9 +71,15 @@
     CALL trace_start("compute_pvort_only")  
 !!! Compute shallow-water potential vorticity
+
     IF(dysl_pvort_only) THEN
+      CALL abort_acc("HEVI_scheme/dysl_pvort_only")
 #include "../kernels/pvort_only.k90"
     ELSE
 
+    !$acc data async &
+    !$acc present(rhodz(:,:), u(:,:), qu(:,:), qv(:,:), Av(:), Riv2(:,:), fv(:))
+    
     radius_m2=radius**(-2)
+    !$acc parallel loop collapse(2) async
     DO l = ll_begin,ll_end
        !DIR$ SIMD
@@ -85,5 +101,8 @@
           qv(ij+z_down,l) =( etav+fv(ij+z_down) )/hv
        ENDDO
-
+    END DO
+
+    !$acc parallel loop collapse(2) async
+    DO l = ll_begin,ll_end
        !DIR$ SIMD
        DO ij=ij_begin,ij_end
@@ -94,6 +113,9 @@
 
     ENDDO
+
+    !$acc end data
    
     END IF ! dysl
+
     CALL trace_end("compute_pvort_only")
 
@@ -409,111 +431,126 @@
 
     IF(dysl_caldyn_fast) THEN
+       CALL abort_acc("HEVI_scheme/dysl_caldyn_fast")
 #include "../kernels/caldyn_fast.k90"
     ELSE
 
-    ! Compute Bernoulli term
-    IF(boussinesq) THEN
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end         
-             berni(ij,l) = pk(ij,l)
-             ! from now on pk contains the vertically-averaged geopotential
-             pk(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1))
+
+       ! Default case : ported to openacc
+       IF(.not. boussinesq .and. caldyn_thermo /= thermo_moist) THEN
+          !$acc data async &
+          !$acc present(rhodz(:,:), u(:,:),pk(:,:), geopot(:,:), theta(:,:,:), du(:,:))
+
+#define BERNI(ij) .5*(geopot(ij,l)+geopot(ij,l+1))
+          !$acc parallel loop collapse(2) async
+          DO l=ll_begin,ll_end
+             !DIR$ SIMD
+             DO ij=ij_begin,ij_end
+                due_right =  0.5*(theta(ij,l,1)+theta(ij+t_right,l,1))  &
+                     *(pk(ij+t_right,l)-pk(ij,l))        &
+                     +  BERNI(ij+t_right)-BERNI(ij)
+                due_lup = 0.5*(theta(ij,l,1)+theta(ij+t_lup,l,1))    &
+                     *(pk(ij+t_lup,l)-pk(ij,l))          &
+                     +  BERNI(ij+t_lup)-BERNI(ij)
+                due_ldown = 0.5*(theta(ij,l,1)+theta(ij+t_ldown,l,1)) &
+                     *(pk(ij+t_ldown,l)-pk(ij,l))      &
+                     +   BERNI(ij+t_ldown)-BERNI(ij)
+                du(ij+u_right,l) = du(ij+u_right,l) - ne_right*due_right
+                du(ij+u_lup,l)   = du(ij+u_lup,l)   - ne_lup*due_lup
+                du(ij+u_ldown,l) = du(ij+u_ldown,l) - ne_ldown*due_ldown
+                u(ij+u_right,l) = u(ij+u_right,l) + tau*du(ij+u_right,l)
+                u(ij+u_lup,l)   = u(ij+u_lup,l)   + tau*du(ij+u_lup,l)
+                u(ij+u_ldown,l) = u(ij+u_ldown,l) + tau*du(ij+u_ldown,l)
+             END DO
           END DO
-       END DO
-    ELSE ! compressible
-
-       DO l=ll_begin,ll_end
-          SELECT CASE(caldyn_thermo)
-          CASE(thermo_theta) ! vdp = theta.dpi => B = Phi
-             !DIR$ SIMD
-             DO ij=ij_begin,ij_end         
-                berni(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1))
-             END DO
-          CASE(thermo_entropy) ! vdp = dG + sdT => B = Phi + G, G=h-Ts=T*(cpp-s) 
-             !DIR$ SIMD
-             DO ij=ij_begin,ij_end         
-                berni(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
-                     + pk(ij,l)*(cpp-theta(ij,l,1)) ! pk=temperature, theta=entropy
-             END DO
-          CASE(thermo_moist) 
-             !DIR$ SIMD
-             DO ij=ij_begin,ij_end         
-                ! du/dt = grad(Bd)+rv.grad(Bv)+s.grad(T)
-                ! Bd = Phi + gibbs_d
-                ! Bv = Phi + gibbs_v
-                ! pk=temperature, theta=entropy
-                qv = theta(ij,l,2)
-                temp = pk(ij,l)
-                chi = log(temp/Treff)
-                nu = (chi*(cpp+qv*cppv)-theta(ij,l,1))/(Rd+qv*Rv) ! log(p/preff)
-                berni(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
-                     + temp*(cpp*(1.-chi)+Rd*nu)
-                berniv(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
-                     + temp*(cppv*(1.-chi)+Rv*nu)
-            END DO
-          END SELECT
-       END DO
-
-    END IF ! Boussinesq/compressible
+
+#undef BERNI
+
+          !$acc end data
+       ELSE ! Not default case : not ported to openacc
+          CALL abort_acc("HEVI_scheme/compute_caldyn_fast")
+          !!$acc parallel loop gang private(berni(:,:), berniv(:,:)) async
+          DO l=ll_begin,ll_end
+             ! Compute Bernoulliterm
+             IF(boussinesq) THEN
+                !!$acc loop vector
+                !DIR$ SIMD
+                DO ij=ij_begin,ij_end
+                   berni(ij,l) = pk(ij,l)
+                   ! from now on pk contains the vertically-averaged geopotential
+                   pk(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1))
+                END DO
+             ELSE ! compressible
+                SELECT CASE(caldyn_thermo)
+                CASE(thermo_theta) ! vdp = theta.dpi => B = Phi
+                   CALL dynamico_abort("Case already dealt with")
+                CASE(thermo_entropy) ! vdp = dG + sdT => B = Phi + G, G=h-Ts=T*(cpp-s)
+                   !$acc loop vector
+                   !DIR$ SIMD
+                   DO ij=ij_begin,ij_end
+                      berni(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
+                           + pk(ij,l)*(cpp-theta(ij,l,1)) ! pk=temperature, theta=entropy
+                   END DO
+                CASE(thermo_moist)
+!!$acc loop vector
+                   !DIR$ SIMD
+                   DO ij=ij_begin,ij_end
+                      ! du/dt = grad(Bd)+rv.grad(Bv)+s.grad(T)
+                      ! Bd = Phi + gibbs_d
+                      ! Bv = Phi + gibbs_v
+                      ! pk=temperature, theta=entropy
+                      qv = theta(ij,l,2)
+                      temp = pk(ij,l)
+                      chi = log(temp/Treff)
+                      nu = (chi*(cpp+qv*cppv)-theta(ij,l,1))/(Rd+qv*Rv) ! log(p/preff)
+                      berni(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
+                           + temp*(cpp*(1.-chi)+Rd*nu)
+                      berniv(ij,l) = .5*(geopot(ij,l)+geopot(ij,l+1)) &
+                           + temp*(cppv*(1.-chi)+Rv*nu)
+                   END DO
+                END SELECT
+             END IF ! Boussinesq/compressible
 
 !!! u:=u+tau*du, du = -grad(B)-theta.grad(pi)
-    DO l=ll_begin,ll_end
-       IF(caldyn_thermo == thermo_moist) THEN
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end         
-             due_right =  berni(ij+t_right,l)-berni(ij,l)       &
-                  + 0.5*(theta(ij,l,1)+theta(ij+t_right,l,1))   &
-                       *(pk(ij+t_right,l)-pk(ij,l))             &
-                  + 0.5*(theta(ij,l,2)+theta(ij+t_right,l,2))   &
-                       *(berniv(ij+t_right,l)-berniv(ij,l))
-             
-             due_lup = berni(ij+t_lup,l)-berni(ij,l)            &
-                  + 0.5*(theta(ij,l,1)+theta(ij+t_lup,l,1))     &
-                       *(pk(ij+t_lup,l)-pk(ij,l))               &
-                  + 0.5*(theta(ij,l,2)+theta(ij+t_lup,l,2))     &
-                       *(berniv(ij+t_lup,l)-berniv(ij,l))
-             
-             due_ldown = berni(ij+t_ldown,l)-berni(ij,l)        &
-                  + 0.5*(theta(ij,l,1)+theta(ij+t_ldown,l,1))   &
-                       *(pk(ij+t_ldown,l)-pk(ij,l))             &
-                  + 0.5*(theta(ij,l,2)+theta(ij+t_ldown,l,2))   &
-                       *(berniv(ij+t_ldown,l)-berniv(ij,l))
-             
-             du(ij+u_right,l) = du(ij+u_right,l) - ne_right*due_right
-             du(ij+u_lup,l)   = du(ij+u_lup,l)   - ne_lup*due_lup
-             du(ij+u_ldown,l) = du(ij+u_ldown,l) - ne_ldown*due_ldown
-             u(ij+u_right,l) = u(ij+u_right,l) + tau*du(ij+u_right,l)
-             u(ij+u_lup,l)   = u(ij+u_lup,l)   + tau*du(ij+u_lup,l)
-             u(ij+u_ldown,l) = u(ij+u_ldown,l) + tau*du(ij+u_ldown,l)
-          END DO
-       ELSE
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end         
-             due_right =  0.5*(theta(ij,l,1)+theta(ij+t_right,l,1))  &
-                  *(pk(ij+t_right,l)-pk(ij,l))        &
-                  +  berni(ij+t_right,l)-berni(ij,l)
-             due_lup = 0.5*(theta(ij,l,1)+theta(ij+t_lup,l,1))    &
-                  *(pk(ij+t_lup,l)-pk(ij,l))          &
-                  +  berni(ij+t_lup,l)-berni(ij,l)
-             due_ldown = 0.5*(theta(ij,l,1)+theta(ij+t_ldown,l,1)) &
-                  *(pk(ij+t_ldown,l)-pk(ij,l))      &
-                  +   berni(ij+t_ldown,l)-berni(ij,l)
-             du(ij+u_right,l) = du(ij+u_right,l) - ne_right*due_right
-             du(ij+u_lup,l)   = du(ij+u_lup,l)   - ne_lup*due_lup
-             du(ij+u_ldown,l) = du(ij+u_ldown,l) - ne_ldown*due_ldown
-             u(ij+u_right,l) = u(ij+u_right,l) + tau*du(ij+u_right,l)
-             u(ij+u_lup,l)   = u(ij+u_lup,l)   + tau*du(ij+u_lup,l)
-             u(ij+u_ldown,l) = u(ij+u_ldown,l) + tau*du(ij+u_ldown,l)
+             IF(caldyn_thermo == thermo_moist) THEN
+!!$acc loop vector
+                !DIR$ SIMD
+                DO ij=ij_begin,ij_end
+                   due_right =  berni(ij+t_right,l)-berni(ij,l)       &
+                        + 0.5*(theta(ij,l,1)+theta(ij+t_right,l,1))   &
+                        *(pk(ij+t_right,l)-pk(ij,l))             &
+                        + 0.5*(theta(ij,l,2)+theta(ij+t_right,l,2))   &
+                        *(berniv(ij+t_right,l)-berniv(ij,l))
+
+                   due_lup = berni(ij+t_lup,l)-berni(ij,l)            &
+                        + 0.5*(theta(ij,l,1)+theta(ij+t_lup,l,1))     &
+                        *(pk(ij+t_lup,l)-pk(ij,l))               &
+                        + 0.5*(theta(ij,l,2)+theta(ij+t_lup,l,2))     &
+                        *(berniv(ij+t_lup,l)-berniv(ij,l))
+
+                   due_ldown = berni(ij+t_ldown,l)-berni(ij,l)        &
+                        + 0.5*(theta(ij,l,1)+theta(ij+t_ldown,l,1))   &
+                        *(pk(ij+t_ldown,l)-pk(ij,l))             &
+                        + 0.5*(theta(ij,l,2)+theta(ij+t_ldown,l,2))   &
+                        *(berniv(ij+t_ldown,l)-berniv(ij,l))
+
+                   du(ij+u_right,l) = du(ij+u_right,l) - ne_right*due_right
+                   du(ij+u_lup,l)   = du(ij+u_lup,l)   - ne_lup*due_lup
+                   du(ij+u_ldown,l) = du(ij+u_ldown,l) - ne_ldown*due_ldown
+                   u(ij+u_right,l) = u(ij+u_right,l) + tau*du(ij+u_right,l)
+                   u(ij+u_lup,l)   = u(ij+u_lup,l)   + tau*du(ij+u_lup,l)
+                   u(ij+u_ldown,l) = u(ij+u_ldown,l) + tau*du(ij+u_ldown,l)
+                END DO
+             ELSE
+                CALL dynamico_abort("Case already dealt with")
+             END IF
           END DO
        END IF
-    END DO
-
-    END IF ! dysl
+    END IF
     CALL trace_end("compute_caldyn_fast")
 
   END SUBROUTINE compute_caldyn_fast
-
+    
   SUBROUTINE compute_caldyn_Coriolis(hflux,theta,qu, convm,dtheta_rhodz,du)
+    USE geometry, ONLY : Ai, wee
     REAL(rstd),INTENT(IN)  :: hflux(3*iim*jjm,llm)  ! hflux in kg/s
     REAL(rstd),INTENT(IN)  :: theta(iim*jjm,llm,nqdyn) ! active scalars
@@ -534,10 +571,15 @@
 
     ELSE
-#define FTHETA(ij) Ftheta(ij,1)
-
-    DO l=ll_begin, ll_end
-       ! compute theta flux
-       DO iq=1,nqdyn
-       !DIR$ SIMD
+#define FTHETA(ij) Ftheta(ij,l)
+
+    !$acc data async &
+    !$acc create(Ftheta(3*iim*jjm,llm)) &
+    !$acc present(qu(:,:), hflux(:,:), convm(:,:), du(:,:), dtheta_rhodz(:,:,:), theta(:,:,:), Ai(:), wee(:,:,:))
+
+    ! compute theta flux
+    DO iq=1,nqdyn
+       !$acc parallel loop collapse(2) present(Ftheta, theta) async
+       DO l=ll_begin, ll_end
+          !DIR$ SIMD
           DO ij=ij_begin_ext,ij_end_ext      
              FTHETA(ij+u_right) = 0.5*(theta(ij,l,iq)+theta(ij+t_right,l,iq)) &
@@ -548,6 +590,10 @@
                   * hflux(ij+u_ldown,l)
           END DO
+       END DO
+
+       !$acc parallel loop collapse(2) present(Ftheta) async
+       DO l=ll_begin, ll_end
           ! horizontal divergence of fluxes
-       !DIR$ SIMD
+          !DIR$ SIMD
           DO ij=ij_begin,ij_end         
              ! dtheta_rhodz =  -div(flux.theta)
@@ -561,5 +607,8 @@
           END DO
        END DO
-
+    END DO
+
+    !$acc parallel loop collapse(2) present(Ai) async
+    DO l=ll_begin, ll_end
        !DIR$ SIMD
        DO ij=ij_begin,ij_end         
@@ -578,5 +627,5 @@
 
     CASE(energy) ! energy-conserving TRiSK
-
+       !$acc parallel loop collapse(2) present(qu, wee, du) async
        DO l=ll_begin,ll_end
           !DIR$ SIMD
@@ -622,5 +671,6 @@
 
     CASE(enstrophy) ! enstrophy-conserving TRiSK
-
+       
+       !$acc parallel loop collapse(2) present(wee, du) async
        DO l=ll_begin,ll_end
           !DIR$ SIMD
@@ -665,7 +715,11 @@
           END DO
        END DO
+       !$acc end parallel loop
     CASE DEFAULT
        STOP
     END SELECT
+
+    !$acc end data
+
 #undef FTHETA
 
@@ -676,5 +730,6 @@
   END SUBROUTINE compute_caldyn_Coriolis
 
-  SUBROUTINE compute_caldyn_slow_hydro(u,rhodz,hflux,du, zero)
+  SUBROUTINE compute_caldyn_slow_hydro(u,rhodz,hflux,du,zero)
+    USE geometry, ONLY : Ai, le_de
     LOGICAL, INTENT(IN) :: zero
     REAL(rstd),INTENT(IN)  :: u(3*iim*jjm,llm)    ! prognostic "velocity"
@@ -684,5 +739,4 @@
     
     REAL(rstd) :: berni(iim*jjm,llm)  ! Bernoulli function
-    REAL(rstd) :: berni1(iim*jjm)  ! Bernoulli function
     REAL(rstd) :: uu_right, uu_lup, uu_ldown, ke, uu
     INTEGER :: ij,l
@@ -698,9 +752,17 @@
      ELSE
 
-#define BERNI(ij) berni1(ij)
+#define BERNI(ij) berni(ij,l)
 
     DO l = ll_begin, ll_end
-       !  Compute mass fluxes
        IF (caldyn_conserv==energy) CALL test_message(req_qu) 
+    END DO
+    
+    !$acc data async &
+    !$acc create(berni(:,ll_begin:ll_end)) &
+    !$acc present(rhodz(:,ll_begin:ll_end), u(:,ll_begin:ll_end), hflux(:,:), du(:,ll_begin:ll_end), Ai(:), le_de(:))
+
+    !  Compute mass fluxes
+    !$acc parallel loop collapse(2) async
+    DO l = ll_begin, ll_end
        !DIR$ SIMD
        DO ij=ij_begin_ext,ij_end_ext
@@ -715,5 +777,9 @@
           hflux(ij+u_ldown,l)=uu_ldown
        ENDDO
-       ! Compute Bernoulli=kinetic energy
+    END DO
+
+    ! Compute Bernoulli=kinetic energy
+    !$acc parallel loop collapse(2) async
+    DO l = ll_begin, ll_end
        !DIR$ SIMD
        DO ij=ij_begin,ij_end         
@@ -726,6 +792,10 @@
                le_de(ij+u_rdown)*u(ij+u_rdown,l)**2 )  
        ENDDO
-       ! Compute du=-grad(Bernoulli)
-       IF(zero) THEN
+    END DO
+
+    ! Compute du=-grad(Bernoulli)
+    IF(zero) THEN
+       !$acc parallel loop collapse(2) async
+       DO l = ll_begin, ll_end
           !DIR$ SIMD
           DO ij=ij_begin,ij_end
@@ -734,5 +804,8 @@
              du(ij+u_ldown,l) = ne_ldown*(BERNI(ij)-BERNI(ij+t_ldown))
           END DO
-       ELSE
+       END DO
+    ELSE
+       !$acc parallel loop collapse(2) async
+       DO l = ll_begin, ll_end
           !DIR$ SIMD
           DO ij=ij_begin,ij_end
@@ -744,10 +817,13 @@
                   ne_ldown*(BERNI(ij)-BERNI(ij+t_ldown))
           END DO
-       END IF
-    END DO
+       END DO
+    END IF
+
+    !$acc end data
 
 #undef BERNI
 
     END IF ! dysl
+
     CALL trace_end("compute_caldyn_slow_hydro")    
   END SUBROUTINE compute_caldyn_slow_hydro
Index: codes/icosagcm/trunk/src/kernels/advect_horiz.k90
===================================================================
--- codes/icosagcm/trunk/src/kernels/advect_horiz.k90	(revision 926)
+++ codes/icosagcm/trunk/src/kernels/advect_horiz.k90	(revision 953)
@@ -1,52 +1,69 @@
    !--------------------------------------------------------------------------
    !---------------------------- advect_horiz ----------------------------------
+
+   !$acc data create(qflux(:,:)) present(qi(:,:), cc(:,:,:), gradq3d(:,:,:), mass(:,:), hfluxt(:,:), Ai(:), xyz_i(:,:)) async
+
    ! evaluate tracer field at point cc using piecewise linear reconstruction
    ! q(cc)= q0 + gradq.(cc-xyz_i) with xi centroid of hexagon
    ! sign*hfluxt>0 iff outgoing
+   !$acc parallel loop collapse(2) async
    DO l = ll_begin, ll_end
       !DIR$ SIMD
       DO ij=ij_begin_ext, ij_end_ext
          IF(ne_right*hfluxt(ij+u_right,l)>0.) THEN
-            qe = qi(ij,l)
-            qe = qe + (cc(ij+u_right,l,1)-xyz_i(ij,1))*gradq3d(ij,l,1)
-            qe = qe + (cc(ij+u_right,l,2)-xyz_i(ij,2))*gradq3d(ij,l,2)
-            qe = qe + (cc(ij+u_right,l,3)-xyz_i(ij,3))*gradq3d(ij,l,3)
+            ij_tmp = ij
          ELSE
-            qe = qi(ij+t_right,l)
-            qe = qe + (cc(ij+u_right,l,1)-xyz_i(ij+t_right,1))*gradq3d(ij+t_right,l,1)
-            qe = qe + (cc(ij+u_right,l,2)-xyz_i(ij+t_right,2))*gradq3d(ij+t_right,l,2)
-            qe = qe + (cc(ij+u_right,l,3)-xyz_i(ij+t_right,3))*gradq3d(ij+t_right,l,3)
+            ij_tmp = ij+t_right
          END IF
+
+         qe = qi(ij_tmp,l)
+         qe = qe + (cc(ij+u_right,l,1)-xyz_i(ij_tmp,1))*gradq3d(ij_tmp,l,1)
+         qe = qe + (cc(ij+u_right,l,2)-xyz_i(ij_tmp,2))*gradq3d(ij_tmp,l,2)
+         qe = qe + (cc(ij+u_right,l,3)-xyz_i(ij_tmp,3))*gradq3d(ij_tmp,l,3)
+
          qflux(ij+u_right,l) = hfluxt(ij+u_right,l)*qe
-         IF(diagflux_on) qfluxt(ij+u_right,l) = qfluxt(ij+u_right,l)+qflux(ij+u_right,l)
+
          IF(ne_lup*hfluxt(ij+u_lup,l)>0.) THEN
-            qe = qi(ij,l)
-            qe = qe + (cc(ij+u_lup,l,1)-xyz_i(ij,1))*gradq3d(ij,l,1)
-            qe = qe + (cc(ij+u_lup,l,2)-xyz_i(ij,2))*gradq3d(ij,l,2)
-            qe = qe + (cc(ij+u_lup,l,3)-xyz_i(ij,3))*gradq3d(ij,l,3)
+            ij_tmp = ij
          ELSE
-            qe = qi(ij+t_lup,l)
-            qe = qe + (cc(ij+u_lup,l,1)-xyz_i(ij+t_lup,1))*gradq3d(ij+t_lup,l,1)
-            qe = qe + (cc(ij+u_lup,l,2)-xyz_i(ij+t_lup,2))*gradq3d(ij+t_lup,l,2)
-            qe = qe + (cc(ij+u_lup,l,3)-xyz_i(ij+t_lup,3))*gradq3d(ij+t_lup,l,3)
+            ij_tmp = ij+t_lup
          END IF
+
+         qe = qi(ij_tmp,l)
+         qe = qe + (cc(ij+u_lup,l,1)-xyz_i(ij_tmp,1))*gradq3d(ij_tmp,l,1)
+         qe = qe + (cc(ij+u_lup,l,2)-xyz_i(ij_tmp,2))*gradq3d(ij_tmp,l,2)
+         qe = qe + (cc(ij+u_lup,l,3)-xyz_i(ij_tmp,3))*gradq3d(ij_tmp,l,3)
+
          qflux(ij+u_lup,l) = hfluxt(ij+u_lup,l)*qe
-         IF(diagflux_on) qfluxt(ij+u_lup,l) = qfluxt(ij+u_lup,l)+qflux(ij+u_lup,l)
+
          IF(ne_ldown*hfluxt(ij+u_ldown,l)>0.) THEN
-            qe = qi(ij,l)
-            qe = qe + (cc(ij+u_ldown,l,1)-xyz_i(ij,1))*gradq3d(ij,l,1)
-            qe = qe + (cc(ij+u_ldown,l,2)-xyz_i(ij,2))*gradq3d(ij,l,2)
-            qe = qe + (cc(ij+u_ldown,l,3)-xyz_i(ij,3))*gradq3d(ij,l,3)
+            ij_tmp = ij
          ELSE
-            qe = qi(ij+t_ldown,l)
-            qe = qe + (cc(ij+u_ldown,l,1)-xyz_i(ij+t_ldown,1))*gradq3d(ij+t_ldown,l,1)
-            qe = qe + (cc(ij+u_ldown,l,2)-xyz_i(ij+t_ldown,2))*gradq3d(ij+t_ldown,l,2)
-            qe = qe + (cc(ij+u_ldown,l,3)-xyz_i(ij+t_ldown,3))*gradq3d(ij+t_ldown,l,3)
+            ij_tmp = ij+t_ldown
          END IF
+
+         qe = qi(ij_tmp,l)
+         qe = qe + (cc(ij+u_ldown,l,1)-xyz_i(ij_tmp,1))*gradq3d(ij_tmp,l,1)
+         qe = qe + (cc(ij+u_ldown,l,2)-xyz_i(ij_tmp,2))*gradq3d(ij_tmp,l,2)
+         qe = qe + (cc(ij+u_ldown,l,3)-xyz_i(ij_tmp,3))*gradq3d(ij_tmp,l,3)
+
          qflux(ij+u_ldown,l) = hfluxt(ij+u_ldown,l)*qe
-         IF(diagflux_on) qfluxt(ij+u_ldown,l) = qfluxt(ij+u_ldown,l)+qflux(ij+u_ldown,l)
       END DO
    END DO
+
+   IF(diagflux_on) THEN
+     !$acc parallel loop collapse(2) copy(qfluxt(:,:)) async
+     DO l = ll_begin, ll_end
+        !DIR$ SIMD
+        DO ij=ij_begin_ext, ij_end_ext
+           qfluxt(ij+u_right,l) = qfluxt(ij+u_right,l)+qflux(ij+u_right,l)
+           qfluxt(ij+u_lup,l) = qfluxt(ij+u_lup,l)+qflux(ij+u_lup,l)
+           qfluxt(ij+u_ldown,l) = qfluxt(ij+u_ldown,l)+qflux(ij+u_ldown,l)
+        END DO
+     END DO
+   END IF
+
    ! update q and, if update_mass, update mass
+   !$acc parallel loop collapse(2) async
    DO l = ll_begin, ll_end
       !DIR$ SIMD
@@ -71,4 +88,7 @@
       END DO
    END DO
+   
+   !$acc end data
+
    !---------------------------- advect_horiz ----------------------------------
    !--------------------------------------------------------------------------
Index: codes/icosagcm/trunk/src/output/xios_mod.F90
===================================================================
--- codes/icosagcm/trunk/src/output/xios_mod.F90	(revision 926)
+++ codes/icosagcm/trunk/src/output/xios_mod.F90	(revision 953)
@@ -1120,4 +1120,5 @@
    CHARACTER(LEN=*),INTENT(IN) :: name
    REAL(rstd), INTENT(OUT) :: field
+   field=0
  END SUBROUTINE
  
Index: codes/icosagcm/trunk/src/parallel/mpipara.F90
===================================================================
--- codes/icosagcm/trunk/src/parallel/mpipara.F90	(revision 926)
+++ codes/icosagcm/trunk/src/parallel/mpipara.F90	(revision 953)
@@ -14,4 +14,6 @@
   INTEGER,SAVE :: id_mpi ! id for profiling
 
+  INTEGER, SAVE :: device_id
+
   INTERFACE allocate_mpi_buffer
     MODULE PROCEDURE allocate_mpi_buffer_r2, allocate_mpi_buffer_r3,allocate_mpi_buffer_r4
@@ -46,4 +48,5 @@
   USE xios
 #endif
+  USE abort_mod
   IMPLICIT NONE
     CHARACTER(LEN=256) :: required_mode_str
@@ -75,4 +78,7 @@
       END SELECT
       
+      IF (required_mode==MPI_THREAD_SERIALIZED .OR. required_mode==MPI_THREAD_MULTIPLE) THEN
+        CALL abort_acc("mpi_threading_mode /= 'single' .AND. mpi_threading_mode /= 'funneled'")
+      ENDIF
 
       IF (required_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD required'
@@ -120,4 +126,12 @@
     ENDIF
     
+
+#ifdef _OPENACC
+    device_id = setDevice(mpi_size, mpi_rank)
+    PRINT *, 'GPU device ', device_id
+#else
+     device_id = -1
+#endif
+
   END SUBROUTINE  init_mpipara
 
@@ -233,3 +247,64 @@
   END SUBROUTINE free_mpi_buffer_r4
    
+#ifdef _OPENACC
+  FUNCTION setDevice(nprocs, myrank)
+    use iso_c_binding
+    use openacc
+    USE mpi_mod
+    implicit none
+    
+    interface 
+       function gethostid() bind(C)
+       use iso_c_binding
+       integer(C_INT) :: gethostid
+     end function gethostid
+  end interface
+  
+  integer, intent(in) :: nprocs, myrank
+  integer :: hostids(nprocs), localprocs(nprocs)
+  integer :: hostid, ierr, numdev, mydev, i, numlocal
+  integer :: setDevice
+
+  ! get the hostids so we can determine what other processes are on this node
+  hostid = gethostid()
+  call mpi_allgather(hostid,1,MPI_INTEGER,hostids,1,MPI_INTEGER, MPI_COMM_WORLD, ierr)
+
+  ! determine which processors are on this node
+  numlocal = 0
+  localprocs(:) = 0
+  do i = 1, nprocs
+     if (hostid == hostids(i)) then
+        localprocs(i) = numlocal
+        numlocal = numlocal + 1
+     end if
+  end do
+
+  ! get the number of device on this node
+  numdev = acc_get_num_devices(ACC_DEVICE_NVIDIA)
+
+  if (numdev < 1) then
+     print *, "Error: there are no devices available on this host. ABORTING", myrank
+     stop
+  end if
+
+  ! print a warning if the number of devices is less than the number of processes on this node. Having multiple processes share a devices is not recommended
+  if (numdev < numlocal) then
+     if (localprocs(myrank+1) == 1) then
+        ! print warning message only once per node
+        print *, "WARNING: the number of process is greater than the number of GPUs.", myrank
+     end if
+     mydev = mod(localprocs(myrank+1), numdev)
+  else
+     mydev = localprocs(myrank+1)
+  end if
+
+  call acc_set_device_num(mydev,ACC_DEVICE_NVIDIA)
+  call acc_init(ACC_DEVICE_NVIDIA)
+  setDevice = acc_get_device_num(ACC_DEVICE_NVIDIA)
+END FUNCTION setDevice
+
+#endif
+
+     
+     
 END MODULE mpipara
Index: codes/icosagcm/trunk/src/parallel/transfert_mpi.f90
===================================================================
--- codes/icosagcm/trunk/src/parallel/transfert_mpi.f90	(revision 926)
+++ codes/icosagcm/trunk/src/parallel/transfert_mpi.f90	(revision 953)
@@ -5,6 +5,6 @@
   
   TYPE array
-    INTEGER,POINTER :: value(:)
-    INTEGER,POINTER :: sign(:)
+    INTEGER,POINTER :: value(:)=>null()
+    INTEGER,POINTER :: sign(:)=>null()
     INTEGER         :: domain
     INTEGER         :: rank
@@ -13,7 +13,7 @@
     INTEGER         :: offset
     INTEGER         :: ireq
-    INTEGER,POINTER :: buffer(:)
-    REAL,POINTER    :: buffer_r(:)
-    INTEGER,POINTER :: src_value(:)
+    INTEGER,POINTER :: buffer(:)=>null()
+    REAL,POINTER    :: buffer_r(:)=>null()
+    INTEGER,POINTER :: src_value(:)=>null()
   END TYPE array
   
@@ -77,4 +77,5 @@
     LOGICAL :: open      ! for debug
     INTEGER :: number
+    LOGICAL :: ondevice=.false. !<Ready to transfer ondevice field
   END TYPE t_message
 
@@ -942,4 +943,7 @@
 !$OMP BARRIER
 !$OMP MASTER
+    !init off-device
+    message%ondevice=.false.
+
     IF(PRESENT(name)) THEN
        message%name = TRIM(name)
@@ -1058,5 +1062,5 @@
     TYPE(t_message) :: message
 
-    INTEGER :: ireq
+    INTEGER :: ireq, ibuff
 
 !$OMP BARRIER
@@ -1084,7 +1088,31 @@
         ENDDO
 
-      ENDIF      
+      ENDIF
     ENDIF
-    
+
+    !deallocate device data if ondevice
+    if(message%ondevice) then
+      do ireq=1, ndomain
+        do ibuff=1,message%request(ireq)%nsend
+          !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer(:))
+          !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer_r(:))
+          !$acc exit data delete(message%request(ireq)%send(ibuff)%sign(:))
+          !$acc exit data delete(message%request(ireq)%send(ibuff)%src_value(:))
+          !$acc exit data delete(message%request(ireq)%send(ibuff)%value(:))
+        end do
+        do ibuff=1,message%request(ireq)%nrecv
+          !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer(:))
+          !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer_r(:))
+          !$acc exit data delete(message%request(ireq)%recv(ibuff)%sign(:))
+          !$acc exit data delete(message%request(ireq)%recv(ibuff)%src_value(:))
+          !$acc exit data delete(message%request(ireq)%recv(ibuff)%value(:))
+        end do
+      end do
+      DO ireq=1,message%nreq
+        !$acc exit data delete(message%buffers(ireq)%r)
+      ENDDO
+      message%ondevice=.false.
+    end if
+
     DEALLOCATE(message%mpi_req)
     DEALLOCATE(message%buffers)
@@ -1120,4 +1148,39 @@
 
 
+  !!!Update buffers on device for 'message'
+  !!! does create_device_message when not already ondevice
+  SUBROUTINE update_device_message_mpi(message)
+    USE domain_mod
+    IMPLICIT NONE
+    TYPE(t_message), intent(inout) :: message
+    INTEGER :: ireq, ibuff
+
+    !if(.not. message%ondevice) call create_device_message_mpi(message)
+
+    do ireq=1, ndomain
+      do ibuff=1,message%request(ireq)%nsend
+        !device buffers updated even if pointers not attached :
+        !non allocated buffers in 'message' must be set to NULL()
+        !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer(:)) async
+        !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer_r(:)) async
+        !$acc enter data copyin(message%request(ireq)%send(ibuff)%sign(:)) async
+        !$acc enter data copyin(message%request(ireq)%send(ibuff)%src_value(:)) async
+        !$acc enter data copyin(message%request(ireq)%send(ibuff)%value(:)) async
+      end do
+      do ibuff=1,message%request(ireq)%nrecv
+        !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer(:)) async
+        !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer_r(:)) async
+        !$acc enter data copyin(message%request(ireq)%recv(ibuff)%sign(:)) async
+        !$acc enter data copyin(message%request(ireq)%recv(ibuff)%src_value(:)) async
+        !$acc enter data copyin(message%request(ireq)%recv(ibuff)%value(:)) async
+      end do
+    end do
+    DO ireq=1,message%nreq
+      !$acc enter data copyin(message%buffers(ireq)%r) async
+    ENDDO
+    message%ondevice=.true.
+  END SUBROUTINE
+
+  !TODO : add openacc with multiple process
   SUBROUTINE send_message_mpi(field,message)
   USE abort_mod
@@ -1129,4 +1192,5 @@
   USE omp_para
   USE trace
+  USE abort_mod
   IMPLICIT NONE
     TYPE(t_field),POINTER :: field(:)
@@ -1145,5 +1209,5 @@
     INTEGER :: dim3,dim4,d3,d4
     INTEGER,POINTER :: src_value(:)
-    INTEGER :: offset,msize,rank
+    INTEGER :: offset,msize,moffset,rank
     INTEGER :: lbegin, lend
     INTEGER :: max_req
@@ -1152,4 +1216,7 @@
 
     CALL enter_profile(id_mpi)
+
+    !Prepare 'message' for on-device copies if field is on device
+    if( field(1)%ondevice .AND. .NOT. message%ondevice ) call update_device_message_mpi(message)
 
 !$OMP BARRIER
@@ -1195,10 +1262,12 @@
               buffer_r=>message%buffers(ireq)%r
               offset=send%offset
-                                            
-              DO n=1,send%size
+              msize=send%size
+              !$acc parallel loop default(present) async if (field(ind)%ondevice)
+              DO n=1,msize
                 buffer_r(offset+n)=rval2d(value(n))
               ENDDO
 
               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                 !$OMP CRITICAL            
                 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,               &
@@ -1206,4 +1275,5 @@
                 !$OMP END CRITICAL
               ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,               &
                   send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
@@ -1228,6 +1298,7 @@
               src_rval2d=>field(recv%domain)%rval2d
               sgn=>recv%sign
-
-              DO n=1,recv%size
+              msize=recv%size
+              !$acc parallel loop default(present) async if (field(ind)%ondevice)
+              DO n=1,msize
                 rval2d(value(n))=src_rval2d(src_value(n))*sgn(n)
               ENDDO
@@ -1239,4 +1310,5 @@
               buffer_r=>message%buffers(ireq)%r
               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                !$OMP CRITICAL            
                 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,               &
@@ -1244,4 +1316,5 @@
                !$OMP END CRITICAL
               ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                  CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,              &
                    recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
@@ -1278,13 +1351,15 @@
               buffer_r=>message%buffers(ireq)%r
 
-              offset=send%offset*dim3 + (lbegin-1)*send%size
-          
+              msize=send%size
+              moffset=send%offset
               CALL trace_start("copy_to_buffer")
 
+              !$acc parallel loop default(present) async if (field(ind)%ondevice)
               DO d3=lbegin,lend
-                DO n=1,send%size
+                offset=moffset*dim3 + (d3-1)*msize
+                !$acc loop
+                DO n=1,msize
                   buffer_r(n+offset)=rval3d(value(n),d3)
                 ENDDO
-                offset=offset+send%size
               ENDDO
               CALL trace_end("copy_to_buffer")
@@ -1296,4 +1371,5 @@
               IF (is_omp_level_master) THEN
                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                   !$OMP CRITICAL   
                   CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,        &
@@ -1301,4 +1377,5 @@
                   !$OMP END CRITICAL
                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                   CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,        &
                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
@@ -1335,9 +1412,10 @@
               src_rval3d=>field(recv%domain)%rval3d
               sgn=>recv%sign
+              msize=recv%size
 
               CALL trace_start("copy_data")
-
+              !$acc parallel loop collapse(2) default(present) async if (field(ind)%ondevice)
               DO d3=lbegin,lend
-                DO n=1,recv%size
+                DO n=1,msize
                   rval3d(value(n),d3)=src_rval3d(src_value(n),d3)*sgn(n)
                 ENDDO
@@ -1351,4 +1429,5 @@
               IF (is_omp_level_master) THEN
                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                   !$OMP CRITICAL
                   CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,        &
@@ -1356,4 +1435,5 @@
                   !$OMP END CRITICAL
                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                   CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,        &
                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
@@ -1390,15 +1470,17 @@
               ireq=send%ireq
               buffer_r=>message%buffers(ireq)%r
+              msize=send%size
+              moffset=send%offset
 
               CALL trace_start("copy_to_buffer")
+              !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice)
               DO d4=1,dim4
-                offset=send%offset*dim3*dim4 + dim3*send%size*(d4-1) +               &
-                  (lbegin-1)*send%size
-
                 DO d3=lbegin,lend
-                  DO n=1,send%size
+                  offset=moffset*dim3*dim4 + dim3*msize*(d4-1) +               &
+                    (d3-1)*msize
+                  !$acc loop
+                  DO n=1,msize
                     buffer_r(n+offset)=rval4d(value(n),d3,d4)
                   ENDDO
-                  offset=offset+send%size
                 ENDDO
               ENDDO
@@ -1411,4 +1493,5 @@
               IF (is_omp_level_master) THEN
                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                   !$OMP CRITICAL
                   CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,   &
@@ -1416,4 +1499,5 @@
                   !$OMP END CRITICAL
                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                   CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,   &
                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
@@ -1451,9 +1535,11 @@
               src_rval4d=>field(recv%domain)%rval4d
               sgn=>recv%sign
-
+              msize=recv%size
               CALL trace_start("copy_data")
+
+              !$acc parallel loop collapse(3) default(present) async if (field(ind)%ondevice)
               DO d4=1,dim4
                 DO d3=lbegin,lend
-                  DO n=1,recv%size
+                  DO n=1,msize
                     rval4d(value(n),d3,d4)=src_rval4d(src_value(n),d3,d4)*sgn(n)
                   ENDDO
@@ -1469,4 +1555,5 @@
               IF (is_omp_level_master) THEN
                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
                  !$OMP CRITICAL           
                   CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   &
@@ -1474,4 +1561,5 @@
                   !$OMP END CRITICAL
                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
+                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
                   CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   &
                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
@@ -1485,4 +1573,5 @@
 
       IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
+!$acc wait
 !$OMP BARRIER
 !$OMP MASTER        
@@ -1492,6 +1581,14 @@
           msize=message%buffers(ireq)%size
           rank=message%buffers(ireq)%rank
-          CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
-            comm_icosa, message%mpi_req(ireq),ierr)
+          ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation
+          IF (message%ondevice) THEN
+            !$acc host_data use_device(buffer_r) ! if (message%ondevice)
+            CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
+              comm_icosa, message%mpi_req(ireq),ierr)
+            !$acc end host_data
+          ELSE
+            CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
+              comm_icosa, message%mpi_req(ireq),ierr)
+          ENDIF
         ENDDO
 
@@ -1500,6 +1597,14 @@
           msize=message%buffers(ireq)%size
           rank=message%buffers(ireq)%rank
-          CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
-            comm_icosa, message%mpi_req(ireq),ierr)
+          ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation
+          IF (message%ondevice) THEN
+            !$acc host_data use_device(buffer_r) ! if (message%ondevice)
+            CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
+              comm_icosa, message%mpi_req(ireq),ierr)
+            !$acc end host_data
+          ELSE
+            CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          &
+              comm_icosa, message%mpi_req(ireq),ierr)
+          ENDIF
         ENDDO
 
@@ -1552,5 +1657,5 @@
     INTEGER :: ind,n
     INTEGER :: dim3,dim4,d3,d4,lbegin,lend
-    INTEGER :: offset
+    INTEGER :: offset, msize, moffset
 
     message%open=.FALSE.
@@ -1586,5 +1691,7 @@
               sgn=>recv%sign
               offset=recv%offset
-              DO n=1,recv%size
+              msize=recv%size
+              !$acc parallel loop default(present) async if (field(ind)%ondevice)
+              DO n=1,msize
                 rval2d(value(n))=buffer_r(n+offset)*sgn(n)  
               ENDDO
@@ -1621,20 +1728,25 @@
     
               CALL distrib_level(1,dim3, lbegin,lend)
-              offset=recv%offset*dim3 + (lbegin-1)*recv%size
+              msize=recv%size
+              moffset=recv%offset
               CALL trace_start("copy_from_buffer")
               
               IF (req%vector) THEN
+                !$acc parallel loop default(present) async if (field(ind)%ondevice)
                 DO d3=lbegin,lend
-                  DO n=1,recv%size
+                  offset=moffset*dim3 + (d3-1)*msize
+                  !$acc loop
+                  DO n=1,msize
                     rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)  
                   ENDDO
-                  offset=offset+recv%size
                 ENDDO
               ELSE
+                !$acc parallel loop default(present) async if (field(ind)%ondevice)
                 DO d3=lbegin,lend
-                  DO n=1,recv%size
+                  offset=moffset*dim3 + (d3-1)*msize
+                  !$acc loop
+                  DO n=1,msize
                     rval3d(value(n),d3)=buffer_r(n+offset)  
                   ENDDO
-                  offset=offset+recv%size
                 ENDDO
               ENDIF
@@ -1670,13 +1782,16 @@
               CALL distrib_level(1,dim3, lbegin,lend)
               dim4=size(rval4d,3)
+              msize=recv%size
+              moffset=recv%offset
               CALL trace_start("copy_from_buffer")
+              !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice)
               DO d4=1,dim4
-                offset=recv%offset*dim3*dim4 + dim3*recv%size*(d4-1) +               &
-                  (lbegin-1)*recv%size
                 DO d3=lbegin,lend
-                  DO n=1,recv%size
+                  offset=moffset*dim3*dim4 + dim3*msize*(d4-1) +               &
+                    (d3-1)*msize
+                  !$acc loop
+                  DO n=1,msize
                     rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n) 
                   ENDDO
-                  offset=offset+recv%size
                 ENDDO
               ENDDO
@@ -1697,5 +1812,5 @@
 !    CALL trace_end("wait_message_mpi")
 !$OMP BARRIER
-    
+  
     CALL exit_profile(id_mpi)
 
Index: codes/icosagcm/trunk/src/physics/physics.f90
===================================================================
--- codes/icosagcm/trunk/src/physics/physics.f90	(revision 926)
+++ codes/icosagcm/trunk/src/physics/physics.f90	(revision 953)
@@ -27,4 +27,5 @@
   SUBROUTINE init_physics
     USE mpipara
+    USE abort_mod
     USE etat0_mod
     USE physics_dcmip_mod, ONLY : init_physics_dcmip=>init_physics
@@ -118,7 +119,11 @@
     
 !$OMP END PARALLEL
+    IF (phys_type /= phys_none) THEN
+       CALL abort_acc("physics /= 'none'")
+    END IF
   END SUBROUTINE init_physics
 
   SUBROUTINE zero_du_phys()
+    USE abort_mod
     REAL(rstd), DIMENSION(:,:), POINTER :: du
     INTEGER :: ind
@@ -154,4 +159,5 @@
     USE etat0_heldsz_mod
     USE etat0_venus_mod, ONLY : phys_venus => physics
+    USE abort_mod
     INTEGER, INTENT(IN)   :: it
     TYPE(t_field),POINTER :: f_phis(:)
Index: codes/icosagcm/trunk/src/sphere/geometry.f90
===================================================================
--- codes/icosagcm/trunk/src/sphere/geometry.f90	(revision 926)
+++ codes/icosagcm/trunk/src/sphere/geometry.f90	(revision 953)
@@ -266,6 +266,5 @@
     INTEGER :: nb_it=0
     TYPE(t_domain),POINTER :: d
-    INTEGER :: ind,it,i,j,n,k
-    REAL(rstd) :: x1(3),x2(3)
+    INTEGER :: ind,it,i,j,n
     REAL(rstd) :: vect(3,6)
     REAL(rstd) :: centr(3)
@@ -690,4 +689,36 @@
 !    CALL surf_triangle(d%xyz(:,ii_begin,jj_begin),d%xyz(:,ii_begin,jj_end),d%xyz(:,ii_end,jj_begin),S)
  
+    CALL update_device_field(geom%Ai)
+
+    CALL update_device_field(geom%xyz_i)
+    CALL update_device_field(geom%lon_i)
+    CALL update_device_field(geom%lat_i)
+    CALL update_device_field(geom%elon_i)
+    CALL update_device_field(geom%elat_i)
+    CALL update_device_field(geom%centroid)
+
+    CALL update_device_field(geom%xyz_e)
+    CALL update_device_field(geom%lon_e)
+    CALL update_device_field(geom%lat_e)
+    CALL update_device_field(geom%elon_e)
+    CALL update_device_field(geom%elat_e)
+    CALL update_device_field(geom%ep_e)
+    CALL update_device_field(geom%et_e)
+
+    CALL update_device_field(geom%xyz_v)
+    CALL update_device_field(geom%de)
+    CALL update_device_field(geom%le)
+    CALL update_device_field(geom%le_de)
+    CALL update_device_field(geom%bi)
+    CALL update_device_field(geom%Av)
+    CALL update_device_field(geom%S1)
+    CALL update_device_field(geom%S2)
+    CALL update_device_field(geom%Riv)
+    CALL update_device_field(geom%Riv2)
+    CALL update_device_field(geom%ne)
+    CALL update_device_field(geom%Wee)
+    CALL update_device_field(geom%bi)
+    CALL update_device_field(geom%fv)
+
   END SUBROUTINE set_geometry
   
Index: codes/icosagcm/trunk/src/time/euler_scheme.F90
===================================================================
--- codes/icosagcm/trunk/src/time/euler_scheme.F90	(revision 953)
+++ codes/icosagcm/trunk/src/time/euler_scheme.F90	(revision 953)
@@ -0,0 +1,253 @@
+MODULE euler_scheme_mod
+  USE field_mod
+  USE abort_mod
+  IMPLICIT NONE
+  PRIVATE
+
+  TYPE(t_field),POINTER,SAVE,PUBLIC :: f_geopot(:), f_q(:), &
+       f_rhodz(:), f_mass(:), f_massm1(:), f_massm2(:), f_dmass(:), & ! current and previous time steps + tendency of mass,
+       f_phis(:), f_ps(:),f_psm1(:), f_psm2(:), f_dps(:), &           ! column-integrated mass
+       f_u(:),f_um1(:),f_um2(:), f_du(:), f_W(:), &                   ! 'horizontal' and vertical (NH) momentum
+       f_theta_rhodz(:),f_theta_rhodzm1(:),f_theta_rhodzm2(:), f_dtheta_rhodz(:), & ! mass-weighted theta/entropy
+       f_hflux(:), f_wflux(:), f_hfluxt(:), f_wfluxt(:), &            ! accumulated mass fluxes
+       f_du_slow(:,:), f_du_fast(:,:), &                              ! slow/fast trend arrays 
+       f_dmass_slow(:,:), f_dps_slow(:,:), f_dtheta_rhodz_slow(:,:), &! for HEVI time scheme 
+       f_dPhi_slow(:,:), f_dPhi_fast(:,:), &                          ! geopotential tendencies (NH)
+       f_dW_slow(:,:), f_dW_fast(:,:)                                 ! vertical momentum tendencies (NH)
+
+  INTEGER, PARAMETER, PUBLIC :: explicit=1, hevi=2, euler=1, rk4=2, mlf=3, rk25=4, ark23=6, ark33=7
+
+  INTEGER,SAVE, PUBLIC :: nb_stage, matsuno_period, scheme, scheme_family
+  !$OMP THREADPRIVATE(nb_stage, matsuno_period, scheme, scheme_family)
+
+  PUBLIC :: euler_scheme, accumulate_fluxes, legacy_to_DEC, DEC_to_legacy
+CONTAINS
+
+  SUBROUTINE Euler_scheme(with_dps,fluxt_zero)
+    USE icosa
+    USE disvert_mod
+    USE omp_para
+    USE trace
+    LOGICAL :: with_dps
+    LOGICAL, OPTIONAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating fluxes in time
+    REAL(rstd),POINTER :: ps(:), dps(:)
+    REAL(rstd),POINTER :: u(:,:) , du(:,:)
+    REAL(rstd),POINTER :: mass(:,:), dmass(:,:)
+    REAL(rstd),POINTER :: theta_rhodz(:,:,:), dtheta_rhodz(:,:,:)
+    REAL(rstd),POINTER :: hflux(:,:),wflux(:,:),hfluxt(:,:),wfluxt(:,:)
+    INTEGER :: ind
+    INTEGER :: ij,l
+    CALL trace_start("Euler_scheme")  
+
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+
+       IF(with_dps) THEN ! update ps/mass
+          CALL abort_acc("Euler_scheme/with_dps")
+          IF(caldyn_eta==eta_mass) THEN ! update ps
+             ps=f_ps(ind) ; dps=f_dps(ind) ;              
+             IF (is_omp_first_level) THEN
+                !DIR$ SIMD
+                DO ij=ij_begin,ij_end
+                   ps(ij)=ps(ij)+dt*dps(ij)
+                ENDDO
+             ENDIF
+          ELSE ! update mass
+             mass=f_mass(ind) ; dmass=f_dmass(ind) ;              
+             DO l=ll_begin,ll_end
+                !DIR$ SIMD
+                DO ij=ij_begin,ij_end
+                   mass(ij,l)=mass(ij,l)+dt*dmass(ij,l)
+                ENDDO
+             END DO
+          END IF
+
+          hflux=f_hflux(ind);     hfluxt=f_hfluxt(ind)
+          wflux=f_wflux(ind);     wfluxt=f_wfluxt(ind)
+          CALL accumulate_fluxes(hflux,wflux,hfluxt,wfluxt,dt,fluxt_zero(ind))
+       END IF ! update ps/mass
+
+       u=f_u(ind) ; theta_rhodz=f_theta_rhodz(ind)
+       du=f_du(ind) ; dtheta_rhodz=f_dtheta_rhodz(ind)
+
+       CALL compute_euler_scheme(u, du, theta_rhodz, dtheta_rhodz)
+    ENDDO
+
+    CALL trace_end("Euler_scheme")
+
+    CONTAINS
+
+    SUBROUTINE compute_euler_scheme(u, du, theta_rhodz, dtheta_rhodz)
+       REAL(rstd),INTENT(INOUT) :: u(iim*3*jjm,llm)
+       REAL(rstd),INTENT(IN)    :: du(iim*3*jjm,llm)
+       REAL(rstd),INTENT(INOUT) :: theta_rhodz(iim*jjm,llm,nqdyn)
+       REAL(rstd),INTENT(IN)    :: dtheta_rhodz(iim*jjm,llm,nqdyn)
+
+       !$acc data present(theta_rhodz(:,:,:), u(:,:),du(:,:), dtheta_rhodz(:,:,:)) async
+
+       !$acc parallel loop async
+       DO l=ll_begin,ll_end
+          !$acc loop
+          !DIR$ SIMD
+          DO ij=ij_begin,ij_end
+             u(ij+u_right,l)=u(ij+u_right,l)+dt*du(ij+u_right,l)
+             u(ij+u_lup,l)=u(ij+u_lup,l)+dt*du(ij+u_lup,l)
+             u(ij+u_ldown,l)=u(ij+u_ldown,l)+dt*du(ij+u_ldown,l)
+             theta_rhodz(ij,l,1)=theta_rhodz(ij,l,1)+dt*dtheta_rhodz(ij,l,1)
+          ENDDO
+       ENDDO
+       
+       !$acc end data
+    END SUBROUTINE compute_euler_scheme
+
+  END SUBROUTINE Euler_scheme
+
+  SUBROUTINE accumulate_fluxes(hflux,wflux, hfluxt,wfluxt, tau,fluxt_zero)
+    USE dimensions
+    USE omp_para
+    USE disvert_mod
+    IMPLICIT NONE
+    REAL(rstd), INTENT(IN)    :: hflux(3*iim*jjm,llm), wflux(iim*jjm,llm+1)
+    REAL(rstd), INTENT(INOUT) :: hfluxt(3*iim*jjm,llm), wfluxt(iim*jjm,llm+1)
+    REAL(rstd), INTENT(IN) :: tau
+    LOGICAL, INTENT(INOUT) :: fluxt_zero
+    INTEGER :: l,ij
+
+    !$acc data present(hflux(:,:), wflux(:,:), hfluxt(:,:), wfluxt(:,:)) async
+
+    IF(fluxt_zero) THEN
+
+       fluxt_zero=.FALSE.
+       !$acc parallel loop async
+       DO l=ll_begin,ll_end
+          !$acc loop
+          !DIR$ SIMD
+          DO ij=ij_begin_ext,ij_end_ext
+             hfluxt(ij+u_right,l) = tau*hflux(ij+u_right,l)
+             hfluxt(ij+u_lup,l) = tau*hflux(ij+u_lup,l)
+             hfluxt(ij+u_ldown,l) = tau*hflux(ij+u_ldown,l)
+          ENDDO
+       ENDDO
+
+       IF(caldyn_eta==eta_mass) THEN ! no need for vertical fluxes if eta_lag
+          !$acc parallel loop async
+          DO l=ll_begin,ll_endp1
+             !$acc loop
+             !DIR$ SIMD
+             DO ij=ij_begin,ij_end
+                wfluxt(ij,l) = tau*wflux(ij,l)
+             ENDDO
+          ENDDO
+       END IF
+
+    ELSE
+       !$acc parallel loop async
+       DO l=ll_begin,ll_end
+          !$acc loop
+          !DIR$ SIMD
+          DO ij=ij_begin_ext,ij_end_ext
+             hfluxt(ij+u_right,l) = hfluxt(ij+u_right,l)+tau*hflux(ij+u_right,l)
+             hfluxt(ij+u_lup,l) = hfluxt(ij+u_lup,l)+tau*hflux(ij+u_lup,l)
+             hfluxt(ij+u_ldown,l) = hfluxt(ij+u_ldown,l)+tau*hflux(ij+u_ldown,l)
+          ENDDO
+       ENDDO
+
+       IF(caldyn_eta==eta_mass) THEN ! no need for vertical fluxes if eta_lag
+          !$acc parallel loop async
+          DO l=ll_begin,ll_endp1
+             !$acc loop
+             !DIR$ SIMD
+             DO ij=ij_begin,ij_end
+                wfluxt(ij,l) = wfluxt(ij,l)+tau*wflux(ij,l)
+             ENDDO
+          ENDDO
+       END IF
+    END IF
+    !$acc end data
+  END SUBROUTINE accumulate_fluxes
+
+  SUBROUTINE legacy_to_DEC(f_ps, f_u)
+    USE icosa
+    USE disvert_mod
+    USE omp_para
+    USE trace
+    TYPE(t_field),POINTER :: f_ps(:), f_u(:)
+    REAL(rstd), POINTER :: ps(:), u(:,:)
+    INTEGER :: ind,ij,l
+
+    CALL trace_start("legacy_to_DEC")
+
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+
+       IF(caldyn_eta==eta_mass .AND. is_omp_first_level) THEN ! update ps
+          ps=f_ps(ind)
+          !$acc parallel loop async default(present)
+          !DIR$ SIMD
+          DO ij=ij_begin,ij_end
+             ps(ij)=(ps(ij)-ptop)/g ! convert ps to column-integrated mass
+          ENDDO
+       END IF
+
+       u=f_u(ind)
+       !$acc parallel loop async default(present)
+       DO l=ll_begin,ll_end
+          !$acc loop
+          !DIR$ SIMD
+          DO ij=ij_begin,ij_end
+             u(ij+u_right,l)=u(ij+u_right,l)*de(ij+u_right)
+             u(ij+u_lup,l)=u(ij+u_lup,l)*de(ij+u_lup)
+             u(ij+u_ldown,l)=u(ij+u_ldown,l)*de(ij+u_ldown)
+          ENDDO
+       ENDDO
+    ENDDO
+
+    CALL trace_end("legacy_to_DEC")  
+
+  END SUBROUTINE Legacy_to_DEC
+
+  SUBROUTINE DEC_to_legacy(f_ps, f_u)
+    USE icosa
+    USE disvert_mod
+    USE omp_para
+    USE trace
+    TYPE(t_field),POINTER :: f_ps(:), f_u(:)
+    REAL(rstd), POINTER :: ps(:), u(:,:)
+    INTEGER :: ind,ij,l
+    CALL trace_start("legacy_to_DEC")
+
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+
+       IF(caldyn_eta==eta_mass .AND. is_omp_first_level) THEN
+          ps=f_ps(ind)
+          !$acc parallel loop async default(present)
+          !DIR$ SIMD
+          DO ij=ij_begin,ij_end
+             ps(ij)=ptop+ps(ij)*g ! convert column-integrated mass to ps
+          ENDDO
+       ENDIF
+       
+       u=f_u(ind)
+       !$acc parallel loop async default(present)
+       DO l=ll_begin,ll_end
+          !$acc loop
+          !DIR$ SIMD
+          DO ij=ij_begin,ij_end
+             u(ij+u_right,l)=u(ij+u_right,l)/de(ij+u_right)
+             u(ij+u_lup,l)=u(ij+u_lup,l)/de(ij+u_lup)
+             u(ij+u_ldown,l)=u(ij+u_ldown,l)/de(ij+u_ldown)
+          ENDDO
+       ENDDO
+    ENDDO
+
+    CALL trace_end("DEC_to_legacy")  
+  END SUBROUTINE DEC_to_legacy
+
+END MODULE euler_scheme_mod
Index: codes/icosagcm/trunk/src/time/euler_scheme.f90
===================================================================
--- codes/icosagcm/trunk/src/time/euler_scheme.f90	(revision 926)
+++ 	(revision )
@@ -1,219 +1,0 @@
-MODULE euler_scheme_mod
-  USE field_mod
-  IMPLICIT NONE
-  PRIVATE
-
-  TYPE(t_field),POINTER,SAVE,PUBLIC :: f_geopot(:), f_q(:), &
-       f_rhodz(:), f_mass(:), f_massm1(:), f_massm2(:), f_dmass(:), & ! current and previous time steps + tendency of mass,
-       f_phis(:), f_ps(:),f_psm1(:), f_psm2(:), f_dps(:), &           ! column-integrated mass
-       f_u(:),f_um1(:),f_um2(:), f_du(:), f_W(:), &                   ! 'horizontal' and vertical (NH) momentum
-       f_theta_rhodz(:),f_theta_rhodzm1(:),f_theta_rhodzm2(:), f_dtheta_rhodz(:), & ! mass-weighted theta/entropy
-       f_hflux(:), f_wflux(:), f_hfluxt(:), f_wfluxt(:), &            ! accumulated mass fluxes
-       f_du_slow(:,:), f_du_fast(:,:), &                              ! slow/fast trend arrays 
-       f_dmass_slow(:,:), f_dps_slow(:,:), f_dtheta_rhodz_slow(:,:), &! for HEVI time scheme 
-       f_dPhi_slow(:,:), f_dPhi_fast(:,:), &                          ! geopotential tendencies (NH)
-       f_dW_slow(:,:), f_dW_fast(:,:)                                 ! vertical momentum tendencies (NH)
-
-  INTEGER, PARAMETER, PUBLIC :: explicit=1, hevi=2, euler=1, rk4=2, mlf=3, rk25=4, ark23=6, ark33=7
-
-  INTEGER,SAVE, PUBLIC :: nb_stage, matsuno_period, scheme, scheme_family
-  !$OMP THREADPRIVATE(nb_stage, matsuno_period, scheme, scheme_family)
-
-  PUBLIC :: euler_scheme, accumulate_fluxes, legacy_to_DEC, DEC_to_legacy
-CONTAINS
-
-  SUBROUTINE Euler_scheme(with_dps,fluxt_zero)
-    USE icosa
-    USE disvert_mod
-    USE omp_para
-    USE trace
-    LOGICAL :: with_dps
-    LOGICAL, OPTIONAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating fluxes in time
-    REAL(rstd),POINTER :: ps(:), dps(:)
-    REAL(rstd),POINTER :: u(:,:) , du(:,:)
-    REAL(rstd),POINTER :: mass(:,:), dmass(:,:)
-    REAL(rstd),POINTER :: theta_rhodz(:,:,:), dtheta_rhodz(:,:,:)
-    REAL(rstd),POINTER :: hflux(:,:),wflux(:,:),hfluxt(:,:),wfluxt(:,:)
-    INTEGER :: ind
-    INTEGER :: ij,l
-    CALL trace_start("Euler_scheme")  
-
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-
-       IF(with_dps) THEN ! update ps/mass
-          IF(caldyn_eta==eta_mass) THEN ! update ps
-             ps=f_ps(ind) ; dps=f_dps(ind) ;              
-             IF (is_omp_first_level) THEN
-                !DIR$ SIMD
-                DO ij=ij_begin,ij_end
-                   ps(ij)=ps(ij)+dt*dps(ij)
-                ENDDO
-             ENDIF
-          ELSE ! update mass
-             mass=f_mass(ind) ; dmass=f_dmass(ind) ;              
-             DO l=ll_begin,ll_end
-                !DIR$ SIMD
-                DO ij=ij_begin,ij_end
-                   mass(ij,l)=mass(ij,l)+dt*dmass(ij,l)
-                ENDDO
-             END DO
-          END IF
-
-          hflux=f_hflux(ind);     hfluxt=f_hfluxt(ind)
-          wflux=f_wflux(ind);     wfluxt=f_wfluxt(ind)
-          CALL accumulate_fluxes(hflux,wflux,hfluxt,wfluxt,dt,fluxt_zero(ind))
-       END IF ! update ps/mass
-
-       u=f_u(ind) ; theta_rhodz=f_theta_rhodz(ind)
-       du=f_du(ind) ; dtheta_rhodz=f_dtheta_rhodz(ind)
-
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end
-             u(ij+u_right,l)=u(ij+u_right,l)+dt*du(ij+u_right,l)
-             u(ij+u_lup,l)=u(ij+u_lup,l)+dt*du(ij+u_lup,l)
-             u(ij+u_ldown,l)=u(ij+u_ldown,l)+dt*du(ij+u_ldown,l)
-             theta_rhodz(ij,l,1)=theta_rhodz(ij,l,1)+dt*dtheta_rhodz(ij,l,1)
-          ENDDO
-       ENDDO
-    ENDDO
-
-    CALL trace_end("Euler_scheme")  
-
-  END SUBROUTINE Euler_scheme
-
-  SUBROUTINE accumulate_fluxes(hflux,wflux, hfluxt,wfluxt, tau,fluxt_zero)
-    USE dimensions
-    USE omp_para
-    USE disvert_mod
-    IMPLICIT NONE
-    REAL(rstd), INTENT(IN)    :: hflux(3*iim*jjm,llm), wflux(iim*jjm,llm+1)
-    REAL(rstd), INTENT(INOUT) :: hfluxt(3*iim*jjm,llm), wfluxt(iim*jjm,llm+1)
-    REAL(rstd), INTENT(IN) :: tau
-    LOGICAL, INTENT(INOUT) :: fluxt_zero
-    INTEGER :: l,ij
-
-    IF(fluxt_zero) THEN
-
-       fluxt_zero=.FALSE.
-
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin_ext,ij_end_ext
-             hfluxt(ij+u_right,l) = tau*hflux(ij+u_right,l)
-             hfluxt(ij+u_lup,l) = tau*hflux(ij+u_lup,l)
-             hfluxt(ij+u_ldown,l) = tau*hflux(ij+u_ldown,l)
-          ENDDO
-       ENDDO
-
-       IF(caldyn_eta==eta_mass) THEN ! no need for vertical fluxes if eta_lag
-          DO l=ll_begin,ll_endp1
-             !DIR$ SIMD
-             DO ij=ij_begin,ij_end
-                wfluxt(ij,l) = tau*wflux(ij,l)
-             ENDDO
-          ENDDO
-       END IF
-
-    ELSE
-
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin_ext,ij_end_ext
-             hfluxt(ij+u_right,l) = hfluxt(ij+u_right,l)+tau*hflux(ij+u_right,l)
-             hfluxt(ij+u_lup,l) = hfluxt(ij+u_lup,l)+tau*hflux(ij+u_lup,l)
-             hfluxt(ij+u_ldown,l) = hfluxt(ij+u_ldown,l)+tau*hflux(ij+u_ldown,l)
-          ENDDO
-       ENDDO
-
-       IF(caldyn_eta==eta_mass) THEN ! no need for vertical fluxes if eta_lag
-          DO l=ll_begin,ll_endp1
-             !DIR$ SIMD
-             DO ij=ij_begin,ij_end
-                wfluxt(ij,l) = wfluxt(ij,l)+tau*wflux(ij,l)
-             ENDDO
-          ENDDO
-       END IF
-
-    END IF
-
-  END SUBROUTINE accumulate_fluxes
-
-  SUBROUTINE legacy_to_DEC(f_ps, f_u)
-    USE icosa
-    USE disvert_mod
-    USE omp_para
-    USE trace
-    TYPE(t_field),POINTER :: f_ps(:), f_u(:)
-    REAL(rstd), POINTER :: ps(:), u(:,:)
-    INTEGER :: ind,ij,l
-    CALL trace_start("legacy_to_DEC")
-
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-
-       IF(caldyn_eta==eta_mass .AND. is_omp_first_level) THEN ! update ps
-          ps=f_ps(ind)
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end
-             ps(ij)=(ps(ij)-ptop)/g ! convert ps to column-integrated mass
-          ENDDO
-       END IF
-
-       u=f_u(ind)
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end
-             u(ij+u_right,l)=u(ij+u_right,l)*de(ij+u_right)
-             u(ij+u_lup,l)=u(ij+u_lup,l)*de(ij+u_lup)
-             u(ij+u_ldown,l)=u(ij+u_ldown,l)*de(ij+u_ldown)
-          ENDDO
-       ENDDO
-    ENDDO
-
-    CALL trace_end("legacy_to_DEC")  
-  END SUBROUTINE Legacy_to_DEC
-
-  SUBROUTINE DEC_to_legacy(f_ps, f_u)
-    USE icosa
-    USE disvert_mod
-    USE omp_para
-    USE trace
-    TYPE(t_field),POINTER :: f_ps(:), f_u(:)
-    REAL(rstd), POINTER :: ps(:), u(:,:)
-    INTEGER :: ind,ij,l
-    CALL trace_start("legacy_to_DEC")
-
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-
-       IF(caldyn_eta==eta_mass .AND. is_omp_first_level) THEN
-          ps=f_ps(ind)
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end
-             ps(ij)=ptop+ps(ij)*g ! convert column-integrated mass to ps
-          ENDDO
-       ENDIF
-       
-       u=f_u(ind)
-       DO l=ll_begin,ll_end
-          !DIR$ SIMD
-          DO ij=ij_begin,ij_end
-             u(ij+u_right,l)=u(ij+u_right,l)/de(ij+u_right)
-             u(ij+u_lup,l)=u(ij+u_lup,l)/de(ij+u_lup)
-             u(ij+u_ldown,l)=u(ij+u_ldown,l)/de(ij+u_ldown)
-          ENDDO
-       ENDDO
-    ENDDO
-
-    CALL trace_end("DEC_to_legacy")  
-  END SUBROUTINE DEC_to_legacy
-
-END MODULE euler_scheme_mod
Index: codes/icosagcm/trunk/src/time/hevi_scheme.F90
===================================================================
--- codes/icosagcm/trunk/src/time/hevi_scheme.F90	(revision 953)
+++ codes/icosagcm/trunk/src/time/hevi_scheme.F90	(revision 953)
@@ -0,0 +1,177 @@
+MODULE hevi_scheme_mod
+  USE prec
+  USE domain_mod
+  USE field_mod
+  USE euler_scheme_mod
+  USE abort_mod
+  IMPLICIT NONE
+  PRIVATE
+
+  REAL(rstd), SAVE :: wj(3), bjl(3,3), cjl(3,3), taujj(3)
+  REAL(rstd), PARAMETER, DIMENSION(3) :: zero = (/0.,0.,0./)
+
+  PUBLIC :: set_coefs_ark23, set_coefs_ark33, hevi_scheme
+
+CONTAINS
+  SUBROUTINE set_coefs_ark23(dt)
+    ! ARK2 scheme by Giraldo, Kelly, Constantinescu 2013
+    ! See Weller et al., 2013 - ARK2 scheme Fig. 2
+    REAL(rstd) :: dt
+    REAL(rstd), PARAMETER :: delta=.5/SQRT(2.), gamma=1.-2.*delta
+!    REAL(rstd), PARAMETER :: alpha=(3.+SQRT(8.))/6. ! original value in GKC2013
+    REAL(rstd), PARAMETER :: alpha=0.7
+    REAL(rstd), PARAMETER, DIMENSION(3) :: wj = (/delta,delta,gamma/)
+    CALL set_coefs_hevi(dt, &
+         (/ zero, (/2.*gamma,0.,0./), (/1-alpha,alpha,0./), wj /), &
+         (/ zero, (/gamma,gamma,0./), wj, wj /) )
+  END SUBROUTINE set_coefs_ark23
+
+  SUBROUTINE set_coefs_ark33(dt)
+    ! Fully-explicit RK3 scheme disguised as ARK
+    REAL(rstd) :: dt
+    CALL set_coefs_rk(dt, (/ zero, (/.5,0.,0./), (/-1.,2.,0./), (/1./6.,2./3.,1./6./) /) )
+  END SUBROUTINE set_coefs_ark33
+    
+  SUBROUTINE set_coefs_rk(dt, ajl)
+    REAL(rstd) :: dt, ajl(3,4)
+    CALL set_coefs_hevi(dt,ajl,ajl)
+  END SUBROUTINE set_coefs_rk
+
+  SUBROUTINE set_coefs_hevi(dt, ajl_slow, ajl_fast)
+    REAL(rstd) :: dt, ajl_slow(3,4), ajl_fast(3,4) ! fast/slow Butcher tableaus
+    INTEGER :: j
+    DO j=1,3
+       bjl(:,j) = dt*(ajl_slow(:,j+1)-ajl_slow(:,j))
+       cjl(:,j) = dt*(ajl_fast(:,j+1)-ajl_fast(:,j))
+       taujj(j) = dt*ajl_fast(j,j)
+    END DO
+    wj=dt*ajl_slow(:,4)
+  END SUBROUTINE set_coefs_hevi
+
+  SUBROUTINE HEVI_scheme(it, fluxt_zero)
+    USE time_mod
+    USE disvert_mod
+    USE caldyn_hevi_mod
+    USE omp_para
+    USE checksum_mod
+    LOGICAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating fluxes in time
+    INTEGER :: it,j,l, ind
+    REAL(rstd),POINTER :: hflux(:,:),wflux(:,:),hfluxt(:,:),wfluxt(:,:)
+
+    CALL legacy_to_DEC(f_ps, f_u)
+
+    DO j=1,nb_stage
+       CALL caldyn_hevi((j==1) .AND. (MOD(it,itau_out)==0), taujj(j), &
+            f_phis, f_ps,f_mass,f_theta_rhodz,f_u,f_q, &
+            f_W, f_geopot, f_hflux, f_wflux, &
+            f_dps_slow(:,j), f_dmass_slow(:,j), f_dtheta_rhodz_slow(:,j), &
+            f_du_slow(:,j), f_du_fast(:,j), &
+            f_dPhi_slow(:,j), f_dPhi_fast(:,j), &
+            f_dW_slow(:,j), f_dW_fast(:,j) )
+       ! accumulate mass fluxes for transport scheme
+       
+       DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind)) CYCLE
+          CALL swap_dimensions(ind)
+          hflux=f_hflux(ind);     hfluxt=f_hfluxt(ind)
+          wflux=f_wflux(ind);     wfluxt=f_wfluxt(ind)
+          CALL accumulate_fluxes(hflux,wflux, hfluxt,wfluxt, wj(j), fluxt_zero(ind))
+
+       END DO
+       ! update model state
+       DO l=1,j
+          IF(caldyn_eta==eta_mass) THEN
+             CALL update_2D(bjl(l,j), f_ps, f_dps_slow(:,l))
+          ELSE
+             CALL update_3D(bjl(l,j), f_mass, f_dmass_slow(:,l))
+          END IF
+          CALL update_4D(bjl(l,j), f_theta_rhodz, f_dtheta_rhodz_slow(:,l))
+          CALL update_3D(bjl(l,j), f_u, f_du_slow(:,l))
+          CALL update_3D(cjl(l,j), f_u, f_du_fast(:,l))
+          IF(.NOT. hydrostatic) THEN
+             CALL abort_acc("HEVI_scheme/!hydrostatic")
+             CALL update_3D(bjl(l,j), f_W, f_dW_slow(:,l))
+             CALL update_3D(cjl(l,j), f_W, f_dW_fast(:,l))
+             CALL update_3D(bjl(l,j), f_geopot, f_dPhi_slow(:,l))
+             CALL update_3D(cjl(l,j), f_geopot, f_dPhi_fast(:,l))
+          END IF
+
+!$OMP BARRIER       
+       END DO
+    END DO
+    CALL DEC_to_legacy(f_ps, f_u)
+  END SUBROUTINE HEVI_scheme
+  
+  SUBROUTINE update_4D(w, f_y, f_dy)
+    USE dimensions
+    USE grid_param, ONLY : nqdyn
+    REAL(rstd) :: w
+    TYPE(t_field) :: f_y(:), f_dy(:)
+    REAL(rstd), POINTER :: y(:,:,:), dy(:,:,:)
+    INTEGER :: ind, iq
+    IF(w /= 0.) THEN
+       DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind)) CYCLE
+          CALL swap_dimensions(ind)
+          dy=f_dy(ind); y=f_y(ind)
+          DO iq=1,nqdyn
+             CALL compute_update_3D(w,y(:,:,iq),dy(:,:,iq))
+          END DO
+       ENDDO
+    END IF
+  END SUBROUTINE update_4D
+    
+  SUBROUTINE update_3D(w, f_y, f_dy)
+    USE dimensions
+    REAL(rstd) :: w
+    TYPE(t_field) :: f_y(:), f_dy(:)
+    REAL(rstd), POINTER :: y(:,:), dy(:,:)
+    INTEGER :: ind
+    IF(w /= 0.) THEN
+       DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind)) CYCLE
+          CALL swap_dimensions(ind)
+          dy=f_dy(ind); y=f_y(ind)
+          CALL compute_update_3D(w,y,dy)
+       ENDDO
+    END IF
+  END SUBROUTINE update_3D
+    
+  SUBROUTINE compute_update_3D(w, y, dy)
+    USE omp_para
+    USE disvert_mod
+    REAL(rstd) :: w
+    REAL(rstd) :: y(:,:), dy(:,:)
+    INTENT(INOUT) :: y
+    INTENT(IN) :: dy
+    INTEGER :: l
+    !$acc kernels async default(present)
+    DO l=ll_begin,ll_end
+       y(:,l)=y(:,l)+w*dy(:,l)
+    ENDDO
+    !$acc end kernels
+  END SUBROUTINE compute_update_3D
+  
+  SUBROUTINE update_2D(w, f_y, f_dy)
+  USE omp_para
+    REAL(rstd) :: w
+    TYPE(t_field) :: f_y(:), f_dy(:)
+    REAL(rstd), POINTER :: y(:), dy(:)
+    INTEGER :: ind
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       dy=f_dy(ind); y=f_y(ind)
+       IF (is_omp_level_master) CALL compute_update_2D(w,y,dy)
+    ENDDO
+  END SUBROUTINE update_2D
+    
+  SUBROUTINE compute_update_2D(w, y, dy)
+    REAL(rstd) :: w, y(:), dy(:)
+    INTENT(INOUT) :: y
+    INTENT(IN) :: dy
+    !$acc kernels async default(present)
+    y(:)=y(:)+w*dy(:)
+    !$acc end kernels
+  END SUBROUTINE compute_update_2D
+  
+END MODULE hevi_scheme_mod
Index: codes/icosagcm/trunk/src/time/hevi_scheme.f90
===================================================================
--- codes/icosagcm/trunk/src/time/hevi_scheme.f90	(revision 926)
+++ 	(revision )
@@ -1,169 +1,0 @@
-MODULE hevi_scheme_mod
-  USE prec
-  USE domain_mod
-  USE field_mod
-  USE euler_scheme_mod
-  IMPLICIT NONE
-  PRIVATE
-
-  REAL(rstd), SAVE :: wj(3), bjl(3,3), cjl(3,3), taujj(3)
-  REAL(rstd), PARAMETER, DIMENSION(3) :: zero = (/0.,0.,0./)
-
-  PUBLIC :: set_coefs_ark23, set_coefs_ark33, hevi_scheme
-
-CONTAINS
-
-  SUBROUTINE set_coefs_ark23(dt)
-    ! ARK2 scheme by Giraldo, Kelly, Constantinescu 2013
-    ! See Weller et al., 2013 - ARK2 scheme Fig. 2
-    REAL(rstd) :: dt
-    REAL(rstd), PARAMETER :: delta=.5/SQRT(2.), gamma=1.-2.*delta
-!    REAL(rstd), PARAMETER :: alpha=(3.+SQRT(8.))/6. ! original value in GKC2013
-    REAL(rstd), PARAMETER :: alpha=0.7
-    REAL(rstd), PARAMETER, DIMENSION(3) :: wj = (/delta,delta,gamma/)
-    CALL set_coefs_hevi(dt, &
-         (/ zero, (/2.*gamma,0.,0./), (/1-alpha,alpha,0./), wj /), &
-         (/ zero, (/gamma,gamma,0./), wj, wj /) )
-  END SUBROUTINE set_coefs_ark23
-
-  SUBROUTINE set_coefs_ark33(dt)
-    ! Fully-explicit RK3 scheme disguised as ARK
-    REAL(rstd) :: dt
-    CALL set_coefs_rk(dt, (/ zero, (/.5,0.,0./), (/-1.,2.,0./), (/1./6.,2./3.,1./6./) /) )
-  END SUBROUTINE set_coefs_ark33
-    
-  SUBROUTINE set_coefs_rk(dt, ajl)
-    REAL(rstd) :: dt, ajl(3,4)
-    CALL set_coefs_hevi(dt,ajl,ajl)
-  END SUBROUTINE set_coefs_rk
-
-  SUBROUTINE set_coefs_hevi(dt, ajl_slow, ajl_fast)
-    REAL(rstd) :: dt, ajl_slow(3,4), ajl_fast(3,4) ! fast/slow Butcher tableaus
-    INTEGER :: j
-    DO j=1,3
-       bjl(:,j) = dt*(ajl_slow(:,j+1)-ajl_slow(:,j))
-       cjl(:,j) = dt*(ajl_fast(:,j+1)-ajl_fast(:,j))
-       taujj(j) = dt*ajl_fast(j,j)
-    END DO
-    wj=dt*ajl_slow(:,4)
-  END SUBROUTINE set_coefs_hevi
-
-  SUBROUTINE HEVI_scheme(it, fluxt_zero)
-    USE time_mod
-    USE disvert_mod
-    USE caldyn_hevi_mod
-    USE omp_para
-    USE checksum_mod
-    LOGICAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating fluxes in time
-    INTEGER :: it,j,l, ind
-    REAL(rstd),POINTER :: hflux(:,:),wflux(:,:),hfluxt(:,:),wfluxt(:,:)
-
-    CALL legacy_to_DEC(f_ps, f_u)
-    DO j=1,nb_stage
-       CALL caldyn_hevi((j==1) .AND. (MOD(it,itau_out)==0), taujj(j), &
-            f_phis, f_ps,f_mass,f_theta_rhodz,f_u,f_q, &
-            f_W, f_geopot, f_hflux, f_wflux, &
-            f_dps_slow(:,j), f_dmass_slow(:,j), f_dtheta_rhodz_slow(:,j), &
-            f_du_slow(:,j), f_du_fast(:,j), &
-            f_dPhi_slow(:,j), f_dPhi_fast(:,j), &
-            f_dW_slow(:,j), f_dW_fast(:,j) )
-       ! accumulate mass fluxes for transport scheme
-       
-       DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind)) CYCLE
-          CALL swap_dimensions(ind)
-          hflux=f_hflux(ind);     hfluxt=f_hfluxt(ind)
-          wflux=f_wflux(ind);     wfluxt=f_wfluxt(ind)
-          CALL accumulate_fluxes(hflux,wflux, hfluxt,wfluxt, wj(j), fluxt_zero(ind))
-       END DO
-       ! update model state
-       DO l=1,j
-          IF(caldyn_eta==eta_mass) THEN
-             CALL update_2D(bjl(l,j), f_ps, f_dps_slow(:,l))
-          ELSE
-             CALL update_3D(bjl(l,j), f_mass, f_dmass_slow(:,l))
-          END IF
-          CALL update_4D(bjl(l,j), f_theta_rhodz, f_dtheta_rhodz_slow(:,l))
-          CALL update_3D(bjl(l,j), f_u, f_du_slow(:,l))
-          CALL update_3D(cjl(l,j), f_u, f_du_fast(:,l))
-          IF(.NOT. hydrostatic) THEN
-             CALL update_3D(bjl(l,j), f_W, f_dW_slow(:,l))
-             CALL update_3D(cjl(l,j), f_W, f_dW_fast(:,l))
-             CALL update_3D(bjl(l,j), f_geopot, f_dPhi_slow(:,l))
-             CALL update_3D(cjl(l,j), f_geopot, f_dPhi_fast(:,l))
-          END IF
-!$OMP BARRIER       
-       END DO
-    END DO
-    CALL DEC_to_legacy(f_ps, f_u)
-  END SUBROUTINE HEVI_scheme
-  
-  SUBROUTINE update_4D(w, f_y, f_dy)
-    USE dimensions
-    USE grid_param, ONLY : nqdyn
-    REAL(rstd) :: w
-    TYPE(t_field) :: f_y(:), f_dy(:)
-    REAL(rstd), POINTER :: y(:,:,:), dy(:,:,:)
-    INTEGER :: ind, iq
-    IF(w /= 0.) THEN
-       DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind)) CYCLE
-          CALL swap_dimensions(ind)
-          dy=f_dy(ind); y=f_y(ind)
-          DO iq=1,nqdyn
-             CALL compute_update_3D(w,y(:,:,iq),dy(:,:,iq))
-          END DO
-       ENDDO
-    END IF
-  END SUBROUTINE update_4D
-    
-  SUBROUTINE update_3D(w, f_y, f_dy)
-    USE dimensions
-    REAL(rstd) :: w
-    TYPE(t_field) :: f_y(:), f_dy(:)
-    REAL(rstd), POINTER :: y(:,:), dy(:,:)
-    INTEGER :: ind
-    IF(w /= 0.) THEN
-       DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind)) CYCLE
-          CALL swap_dimensions(ind)
-          dy=f_dy(ind); y=f_y(ind)
-          CALL compute_update_3D(w,y,dy)
-       ENDDO
-    END IF
-  END SUBROUTINE update_3D
-    
-  SUBROUTINE compute_update_3D(w, y, dy)
-    USE omp_para
-    USE disvert_mod
-    REAL(rstd) :: w
-    REAL(rstd) :: y(:,:), dy(:,:)
-    INTENT(INOUT) :: y
-    INTENT(IN) :: dy
-    INTEGER :: l
-    DO l=ll_begin,ll_end
-       y(:,l)=y(:,l)+w*dy(:,l)
-    ENDDO
-  END SUBROUTINE compute_update_3D
-  
-  SUBROUTINE update_2D(w, f_y, f_dy)
-  USE omp_para
-    REAL(rstd) :: w
-    TYPE(t_field) :: f_y(:), f_dy(:)
-    REAL(rstd), POINTER :: y(:), dy(:)
-    INTEGER :: ind
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       dy=f_dy(ind); y=f_y(ind)
-       IF (is_omp_level_master) CALL compute_update_2D(w,y,dy)
-    ENDDO
-  END SUBROUTINE update_2D
-    
-  SUBROUTINE compute_update_2D(w, y, dy)
-    REAL(rstd) :: w, y(:), dy(:)
-    INTENT(INOUT) :: y
-    INTENT(IN) :: dy
-    y(:)=y(:)+w*dy(:)
-  END SUBROUTINE compute_update_2D
-  
-END MODULE hevi_scheme_mod
Index: codes/icosagcm/trunk/src/time/timeloop_gcm.F90
===================================================================
--- codes/icosagcm/trunk/src/time/timeloop_gcm.F90	(revision 953)
+++ codes/icosagcm/trunk/src/time/timeloop_gcm.F90	(revision 953)
@@ -0,0 +1,485 @@
+MODULE timeloop_gcm_mod
+  USE profiling_mod
+  USE icosa
+  USE disvert_mod
+  USE trace
+  USE omp_para
+  USE euler_scheme_mod
+  USE explicit_scheme_mod
+  USE hevi_scheme_mod
+  IMPLICIT NONE
+  PRIVATE
+  
+  INTEGER, PARAMETER :: itau_sync=10
+  TYPE(t_message),SAVE :: req_ps0, req_mass0, req_theta_rhodz0, req_u0, req_q0, req_W0, req_geopot0
+  LOGICAL, SAVE :: positive_theta
+  INTEGER :: itau_prof, id_timeloop, id_dyn, id_phys, id_dissip, id_adv, id_diags
+  PUBLIC :: init_timeloop, timeloop
+
+CONTAINS
+  
+  SUBROUTINE init_timeloop
+    USE dissip_gcm_mod
+    USE observable_mod
+    USE caldyn_mod
+    USE etat0_mod
+    USE guided_mod
+    USE advect_tracer_mod
+    USE check_conserve_mod
+    USE output_field_mod
+    USE theta2theta_rhodz_mod
+    USE sponge_mod
+
+    CHARACTER(len=255) :: def
+
+    CALL register_id('timeloop',id_timeloop)
+    CALL register_id('dyn',id_dyn)
+    CALL register_id('dissip',id_dissip)
+    CALL register_id('phys',id_phys)
+    CALL register_id('adv',id_adv)
+    CALL register_id('diags',id_diags)
+
+    CALL init_caldyn
+    
+!    IF (xios_output) itau_out=1
+    IF (.NOT. enable_io) itau_out=HUGE(itau_out)
+
+    itau_prof=100
+    CALL getin('itau_profiling',itau_prof)
+
+    positive_theta=.FALSE.
+    CALL getin('positive_theta',positive_theta)
+    IF(positive_theta .AND. nqtot<1) THEN
+       PRINT *, 'nqtot must be >0 if positive_theta is .TRUE.'
+       STOP
+    END IF
+
+    def='ARK2.3'
+    CALL getin('time_scheme',def)
+    SELECT CASE (TRIM(def))
+    CASE('euler')
+       scheme_family=explicit
+       scheme=euler
+       nb_stage=1
+    CASE ('runge_kutta')
+       scheme_family=explicit
+       scheme=rk4
+       nb_stage=4
+    CASE ('RK2.5')
+       scheme_family=explicit
+       scheme=rk25
+       nb_stage=5
+    CASE ('leapfrog_matsuno')
+       scheme_family=explicit
+       scheme=mlf
+       matsuno_period=5
+       CALL getin('matsuno_period',matsuno_period)
+       nb_stage=matsuno_period+1
+    CASE('ARK2.3')
+       scheme_family=hevi
+       scheme=ark23
+       nb_stage=3
+       CALL set_coefs_ark23(dt)
+    CASE('ARK3.3')
+       scheme_family=hevi
+       scheme=ark33
+       nb_stage=3
+       CALL set_coefs_ark33(dt)
+    CASE ('none')
+       nb_stage=0
+    CASE default
+       PRINT*,'Bad selector for variable scheme : <', TRIM(def),             &
+            ' > options are <euler>, <runge_kutta>, <leapfrog_matsuno>,<RK2.5>,<ARK2.3>'
+       STOP
+    END SELECT
+    
+    IF (scheme_family /= hevi) THEN
+       CALL abort_acc("scheme_family /= hevi")
+    END IF
+
+    ! Time-independant orography
+    CALL allocate_field(f_phis,field_t,type_real,name='phis')
+    ! Model state at current time step
+    CALL allocate_field(f_ps,field_t,type_real, name='ps')
+    CALL allocate_field(f_mass,field_t,type_real,llm,name='mass')
+    CALL allocate_field(f_rhodz,field_t,type_real,llm,name='rhodz')
+    CALL allocate_field(f_theta_rhodz,field_t,type_real,llm,nqdyn,name='theta_rhodz')
+    CALL allocate_field(f_u,field_u,type_real,llm,name='u')
+    CALL allocate_field(f_geopot,field_t,type_real,llm+1,name='geopot')
+    CALL allocate_field(f_W,field_t,type_real,llm+1,name='W') ! used only if .not. hydrostatic
+    CALL allocate_field(f_q,field_t,type_real,llm,nqtot,'q')
+    ! Mass fluxes
+    CALL allocate_field(f_hflux,field_u,type_real,llm, ondevice=.TRUE.)    ! instantaneous mass fluxes
+    CALL allocate_field(f_hfluxt,field_u,type_real,llm,ondevice=.TRUE.)   ! mass "fluxes" accumulated in time
+    CALL allocate_field(f_wflux,field_t,type_real,llm+1)  ! vertical mass fluxes
+    CALL allocate_field(f_wfluxt,field_t,type_real,llm+1,name='wfluxt',ondevice=.TRUE.)
+    
+    SELECT CASE(scheme_family)
+    CASE(explicit)
+       ! Trends
+       CALL allocate_field(f_dps,field_t,type_real,name='dps')
+       CALL allocate_field(f_dmass,field_t,type_real,llm, name='dmass')
+       CALL allocate_field(f_dtheta_rhodz,field_t,type_real,llm,nqdyn,name='dtheta_rhodz')
+       CALL allocate_field(f_du,field_u,type_real,llm,name='du')
+       ! Model state at previous time step (RK/MLF)
+       CALL allocate_field(f_psm1,field_t,type_real,name='psm1')
+       CALL allocate_field(f_massm1,field_t,type_real,llm, name='massm1')
+       CALL allocate_field(f_theta_rhodzm1,field_t,type_real,llm,nqdyn,name='theta_rhodzm1')
+       CALL allocate_field(f_um1,field_u,type_real,llm,name='um1')
+    CASE(hevi)
+       ! Trends
+       CALL allocate_fields(nb_stage,f_dps_slow, field_t,type_real,name='dps_slow', ondevice=.TRUE.)
+       CALL allocate_fields(nb_stage,f_dmass_slow, field_t,type_real,llm, name='dmass_slow', ondevice=.TRUE.)
+       CALL allocate_fields(nb_stage,f_dtheta_rhodz_slow, field_t,type_real,llm,nqdyn,name='dtheta_rhodz_fast', ondevice=.TRUE.)
+       CALL allocate_fields(nb_stage,f_du_slow, field_u,type_real,llm,name='du_slow', ondevice=.TRUE.)
+       CALL allocate_fields(nb_stage,f_du_fast, field_u,type_real,llm,name='du_fast', ondevice=.TRUE.)
+       CALL allocate_fields(nb_stage,f_dW_slow, field_t,type_real,llm+1,name='dW_slow')
+       CALL allocate_fields(nb_stage,f_dW_fast, field_t,type_real,llm+1,name='dW_fast')
+       CALL allocate_fields(nb_stage,f_dPhi_slow, field_t,type_real,llm+1,name='dPhi_slow')
+       CALL allocate_fields(nb_stage,f_dPhi_fast, field_t,type_real,llm+1,name='dPhi_fast')
+       f_dps => f_dps_slow(:,1)
+       f_du => f_du_slow(:,1)
+       f_dtheta_rhodz => f_dtheta_rhodz_slow(:,1)
+    END SELECT
+
+    SELECT CASE(scheme)
+    CASE(mlf)
+       ! Model state 2 time steps ago (MLF)
+       CALL allocate_field(f_psm2,field_t,type_real)
+       CALL allocate_field(f_massm2,field_t,type_real,llm)
+       CALL allocate_field(f_theta_rhodzm2,field_t,type_real,llm,nqdyn)
+       CALL allocate_field(f_um2,field_u,type_real,llm)
+    END SELECT
+
+    CALL init_theta2theta_rhodz
+    CALL init_dissip
+    CALL init_sponge
+    CALL init_observable
+    CALL init_guided
+    CALL init_advect_tracer
+    CALL init_check_conserve
+
+    CALL etat0(f_ps,f_mass,f_phis,f_theta_rhodz,f_u, f_geopot,f_W, f_q)
+
+    CALL transfert_request(f_phis,req_i0) 
+    CALL transfert_request(f_phis,req_i1) 
+
+    CALL init_message(f_ps,req_i0,req_ps0)
+    CALL init_message(f_mass,req_i0,req_mass0)
+    CALL init_message(f_theta_rhodz,req_i0,req_theta_rhodz0)
+    CALL init_message(f_u,req_e0_vect,req_u0)
+    CALL init_message(f_q,req_i0,req_q0)
+    CALL init_message(f_geopot,req_i0,req_geopot0)
+    CALL init_message(f_W,req_i0,req_W0)
+
+  END SUBROUTINE init_timeloop
+  
+  SUBROUTINE timeloop
+    USE abort_mod
+    USE dissip_gcm_mod
+    USE sponge_mod
+    USE observable_mod
+    USE etat0_mod
+    USE guided_mod
+    USE caldyn_mod
+    USE advect_tracer_mod
+    USE diagflux_mod
+    USE physics_mod
+    USE mpipara
+    USE transfert_mod
+    USE check_conserve_mod
+    USE xios_mod
+    USE output_field_mod
+    USE write_etat0_mod
+    USE restart_mod
+    USE checksum_mod
+    USE explicit_scheme_mod
+    USE hevi_scheme_mod
+    REAL(rstd),POINTER :: rhodz(:,:), mass(:,:), ps(:)
+
+    REAL(rstd) :: adv_over_out ! ratio itau_adv/itau_out
+    INTEGER :: ind, it,l
+    LOGICAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating mass fluxes in time
+    LOGICAL, PARAMETER :: check_rhodz=.FALSE.
+    INTEGER(kind=8) :: start_clock, stop_clock, rate_clock
+    LOGICAL,SAVE :: first_physic=.TRUE.
+    !$OMP THREADPRIVATE(first_physic)    
+
+    CALL switch_omp_distrib_level
+    CALL caldyn_BC(f_phis, f_geopot, f_wflux) ! set constant values in first/last interfaces
+
+    !$OMP BARRIER
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       rhodz=f_rhodz(ind); mass=f_mass(ind); ps=f_ps(ind)
+       IF(caldyn_eta==eta_mass) THEN
+          CALL compute_rhodz(.TRUE., ps, rhodz, ondevice=.FALSE.) ! save rhodz for transport scheme before dynamics update ps
+       ELSE
+          DO l=ll_begin,ll_end
+             rhodz(:,l)=mass(:,l)
+          ENDDO
+       END IF
+    END DO
+    !$OMP BARRIER
+    fluxt_zero=.TRUE.
+
+    IF(positive_theta) CALL copy_theta_to_q(f_theta_rhodz,f_rhodz,f_q)
+    IF(diagflux_on) THEN
+       adv_over_out = itau_adv*(1./itau_out)
+    ELSE
+       adv_over_out = 0.
+    END IF
+
+    CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,itau0)  
+
+    Call trace_on
+
+    IF (xios_output) THEN ! we must call update_calendar before any XIOS output
+      IF (is_omp_master) CALL xios_update_calendar(1)
+    END IF
+    
+!    IF (write_start) CALL write_etat0(itau0,f_ps, f_phis,f_theta_rhodz,f_u,f_q)
+    IF (write_start) CALL write_etat0(itau0,f_ps, f_phis,f_theta_rhodz,f_u,f_q, f_geopot, f_W)
+   
+    CALL write_output_fields_basic(.TRUE., f_phis, f_ps, f_mass, f_geopot, f_theta_rhodz, f_u, f_W, f_q)
+
+    !$OMP MASTER
+    CALL SYSTEM_CLOCK(start_clock, rate_clock)
+    !$OMP END MASTER   
+    call update_device_field(f_ps)
+    call update_device_field(f_mass)
+    CALL update_device_field(f_theta_rhodz)
+    CALL update_device_field(f_u)
+    CALL update_device_field(f_q)
+    CALL update_device_field(f_geopot)
+    CALL update_device_field(f_wflux)
+    CALL update_device_field(f_rhodz)
+
+
+    DO it=itau0+1,itau0+itaumax
+       IF (is_master) CALL print_iteration(it, itau0, itaumax, start_clock, rate_clock)
+
+       CALL enter_profile(id_timeloop)
+
+       IF (xios_output) THEN
+
+          IF(it>itau0+1 .AND. is_omp_master) CALL xios_update_calendar(it-itau0)
+       ELSE
+          CALL update_time_counter(dt*it)
+       END IF
+
+       IF (it==itau0+1 .OR. MOD(it,itau_sync)==0) THEN
+          CALL send_message(f_ps,req_ps0)
+          CALL wait_message(req_ps0)
+          CALL send_message(f_mass,req_mass0)
+          CALL wait_message(req_mass0)
+          CALL send_message(f_theta_rhodz,req_theta_rhodz0) 
+          CALL wait_message(req_theta_rhodz0)
+          CALL send_message(f_u,req_u0)
+          CALL wait_message(req_u0)
+          CALL send_message(f_q,req_q0) 
+          CALL wait_message(req_q0)
+          IF(.NOT. hydrostatic) THEN
+             CALL send_message(f_geopot,req_geopot0)
+             CALL wait_message(req_geopot0)
+             CALL send_message(f_W,req_W0)
+             CALL wait_message(req_W0)
+          END IF
+       ENDIF
+
+       CALL guided(it*dt,f_ps,f_theta_rhodz,f_u,f_q)
+
+       CALL enter_profile(id_dyn)
+       SELECT CASE(scheme_family)
+       CASE(explicit)
+          CALL abort_acc("explicit_scheme")
+          CALL explicit_scheme(it, fluxt_zero)
+       CASE(hevi)
+          CALL HEVI_scheme(it, fluxt_zero)
+       END SELECT
+       CALL exit_profile(id_dyn)
+
+       CALL enter_profile(id_dissip)
+       IF (MOD(it,itau_dissip)==0) THEN
+          
+          IF(caldyn_eta==eta_mass) THEN
+             !ym flush ps
+             !$OMP BARRIER
+             DO ind=1,ndomain
+                IF (.NOT. assigned_domain(ind)) CYCLE
+                CALL swap_dimensions(ind)
+                CALL swap_geometry(ind)
+                mass=f_mass(ind); ps=f_ps(ind);
+                CALL compute_rhodz(.TRUE., ps, mass, ondevice=.TRUE.)
+             END DO
+          ENDIF
+          
+          CALL enter_profile(id_diags)
+          CALL check_conserve_detailed(it, AAM_dyn, &
+               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+          CALL exit_profile(id_diags)
+       
+          CALL dissip(f_ps,f_mass,f_phis,f_geopot,f_theta_rhodz,f_u, f_dtheta_rhodz,f_du)
+          
+          CALL euler_scheme(.FALSE.)  ! update only u, theta
+          IF (iflag_sponge > 0) THEN
+             CALL abort_acc("iflag_sponge>0")
+             CALL sponge(f_u,f_du,f_theta_rhodz,f_dtheta_rhodz)
+             CALL euler_scheme(.FALSE.)  ! update only u, theta
+          END IF
+
+          CALL enter_profile(id_diags)
+          CALL check_conserve_detailed(it, AAM_dissip, &
+               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+          CALL exit_profile(id_diags)
+       END IF
+       CALL exit_profile(id_dissip)
+
+       CALL enter_profile(id_adv)
+       IF(MOD(it,itau_adv)==0) THEN
+          CALL advect_tracer(f_hfluxt,f_wfluxt,f_u, f_q,f_rhodz, & ! update q and rhodz after RK step
+               adv_over_out, f_masst,f_qmasst,f_massfluxt, f_qfluxt)  ! accumulate mass and fluxes if diagflux_on
+          fluxt_zero=.TRUE. ! restart accumulation of hfluxt and qfluxt at next call to explicit_scheme / HEVI_scheme
+          ! At this point advect_tracer has obtained the halos of u and rhodz,
+          ! needed for correct computation of kinetic energy
+          IF(diagflux_on) CALL abort_acc("diagflux_on")
+          IF(diagflux_on) CALL diagflux_energy(adv_over_out, f_phis,f_rhodz,f_theta_rhodz,f_u, f_geopot,f_theta,f_buf_i, f_hfluxt)
+
+          IF (check_rhodz) THEN ! check that rhodz is consistent with ps
+             DO ind=1,ndomain
+                IF (.NOT. assigned_domain(ind)) CYCLE
+                CALL swap_dimensions(ind)
+                CALL swap_geometry(ind)
+                rhodz=f_rhodz(ind); ps=f_ps(ind);
+                CALL compute_rhodz(.FALSE., ps, rhodz)   
+             END DO
+          ENDIF
+          IF(positive_theta) CALL abort_acc("positive_theta")
+          IF(positive_theta) CALL copy_q_to_theta(f_theta_rhodz,f_rhodz,f_q)
+       END IF
+       CALL exit_profile(id_adv)
+
+       CALL enter_profile(id_diags)
+!       IF (MOD(it,itau_physics)==0) THEN
+          CALL check_conserve_detailed(it, AAM_dyn, &
+            f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+          CALL enter_profile(id_phys)
+          CALL physics(it,f_phis, f_ps, f_theta_rhodz, f_u, f_wflux, f_q)        
+          CALL exit_profile(id_phys)
+          CALL check_conserve_detailed(it, AAM_phys, &
+               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+          !$OMP MASTER
+          IF (first_physic) CALL SYSTEM_CLOCK(start_clock)
+          !$OMP END MASTER   
+          first_physic=.FALSE.
+!       END IF
+
+       IF (MOD(it,itau_check_conserv)==0) THEN
+          CALL update_host_field(f_ps)
+          CALL update_host_field(f_theta_rhodz)
+          CALL update_host_field(f_u)
+          CALL update_host_field(f_dps)
+          CALL update_host_field(f_q)
+          CALL check_conserve_detailed(it, AAM_dyn, &
+               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+          CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,it) 
+       ENDIF
+
+       IF (mod(it,itau_out)==0 ) THEN
+          CALL transfert_request(f_u,req_e1_vect)
+          CALL update_host_field(f_ps)              
+          CALL update_host_field(f_mass)
+          CALL update_host_field(f_theta_rhodz)
+          CALL update_host_field(f_geopot)
+          CALL update_host_field(f_u)
+          CALL update_host_field(f_q)
+          CALL write_output_fields_basic(.FALSE.,f_phis, f_ps, f_mass, f_geopot, f_theta_rhodz, f_u, f_W, f_q)
+       ENDIF
+       CALL exit_profile(id_diags)
+
+       CALL exit_profile(id_timeloop)
+    END DO
+    
+    CALL update_host_field(f_ps)
+    CALL update_host_field(f_theta_rhodz)
+    CALL update_host_field(f_u)
+    CALL update_host_field(f_q)
+    CALL update_host_field(f_geopot)
+
+!    CALL write_etat0(itau0+itaumax,f_ps, f_phis,f_theta_rhodz,f_u,f_q) 
+    CALL write_etat0(itau0+itaumax,f_ps, f_phis,f_theta_rhodz,f_u,f_q, f_geopot, f_W) 
+
+    CALL update_host_field(f_dps)    
+    CALL check_conserve_detailed(it, AAM_dyn, &
+         f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
+    CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,it)  
+    
+    !$OMP MASTER
+    CALL SYSTEM_CLOCK(stop_clock)
+    
+    IF (mpi_rank==0) THEN 
+       PRINT *,"Time elapsed : ",(stop_clock-start_clock)*1./rate_clock 
+    ENDIF
+    !$OMP END MASTER 
+    
+    ! CONTAINS
+  END SUBROUTINE timeloop
+
+  SUBROUTINE print_iteration(it,itau0,itaumax,start_clock,rate_clock)
+    INTEGER :: it, itau0, itaumax, throughput
+    INTEGER(kind=8) :: start_clock, stop_clock, rate_clock
+    REAL :: per_step,total, elapsed
+    WRITE(*,'(A,I7,A,F14.1)') "It No :",it,"   t :",dt*it
+    IF(MOD(it,10)==0) THEN
+       CALL SYSTEM_CLOCK(stop_clock)
+       elapsed = (stop_clock-start_clock)*1./rate_clock
+       per_step = elapsed/(it-itau0)
+       throughput = INT(dt/per_step)
+       total = per_step*itaumax
+       WRITE(*,'(A,I5,A,F6.2,A,I6)') 'Time spent (s):',INT(elapsed), &
+            '  -- ms/step : ', 1000*per_step, &
+            '  -- Throughput :', throughput
+       WRITE(*,'(A,I5,A,I5)') 'Whole job (min) :', INT(total/60.), &
+            '  -- Completion in (min) : ', INT((total-elapsed)/60.)
+    END IF
+    IF(MOD(it,itau_prof)==0) CALL print_profile
+
+  END SUBROUTINE print_iteration
+
+  SUBROUTINE copy_theta_to_q(f_theta_rhodz,f_rhodz,f_q)
+    TYPE(t_field),POINTER :: f_theta_rhodz(:),f_rhodz(:), f_q(:)
+    REAL(rstd), POINTER :: theta_rhodz(:,:,:), rhodz(:,:), q(:,:,:)
+    INTEGER :: ind, iq
+    DO ind=1, ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       theta_rhodz=f_theta_rhodz(ind)
+       rhodz=f_rhodz(ind)
+       q=f_q(ind)
+       DO iq=1, nqdyn
+          q(:,:,iq)  = theta_rhodz(:,:,iq)/rhodz(:,:)
+       END DO
+    END DO
+  END SUBROUTINE copy_theta_to_q
+
+  SUBROUTINE copy_q_to_theta(f_theta_rhodz,f_rhodz,f_q)
+    TYPE(t_field),POINTER :: f_theta_rhodz(:),f_rhodz(:), f_q(:)
+    REAL(rstd), POINTER :: theta_rhodz(:,:,:), rhodz(:,:), q(:,:,:)
+    INTEGER :: ind, iq
+    DO ind=1, ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       theta_rhodz=f_theta_rhodz(ind)
+       rhodz=f_rhodz(ind)
+       q=f_q(ind)
+       DO iq=1,nqdyn
+          theta_rhodz(:,:,iq) = rhodz(:,:)*q(:,:,iq)
+       END DO
+    END DO
+  END SUBROUTINE copy_q_to_theta
+
+END MODULE timeloop_gcm_mod
Index: codes/icosagcm/trunk/src/time/timeloop_gcm.f90
===================================================================
--- codes/icosagcm/trunk/src/time/timeloop_gcm.f90	(revision 926)
+++ 	(revision )
@@ -1,449 +1,0 @@
-MODULE timeloop_gcm_mod
-  USE profiling_mod
-  USE icosa
-  USE disvert_mod
-  USE trace
-  USE omp_para
-  USE euler_scheme_mod
-  USE explicit_scheme_mod
-  USE hevi_scheme_mod
-  IMPLICIT NONE
-  PRIVATE
-  
-  INTEGER, PARAMETER :: itau_sync=10
-  TYPE(t_message),SAVE :: req_ps0, req_mass0, req_theta_rhodz0, req_u0, req_q0, req_W0, req_geopot0
-  LOGICAL, SAVE :: positive_theta
-  INTEGER :: itau_prof, id_timeloop, id_dyn, id_phys, id_dissip, id_adv, id_diags
-  PUBLIC :: init_timeloop, timeloop
-
-CONTAINS
-  
-  SUBROUTINE init_timeloop
-    USE dissip_gcm_mod
-    USE observable_mod
-    USE caldyn_mod
-    USE etat0_mod
-    USE guided_mod
-    USE advect_tracer_mod
-    USE check_conserve_mod
-    USE output_field_mod
-    USE theta2theta_rhodz_mod
-    USE sponge_mod
-
-    CHARACTER(len=255) :: def
-
-    CALL register_id('timeloop',id_timeloop)
-    CALL register_id('dyn',id_dyn)
-    CALL register_id('dissip',id_dissip)
-    CALL register_id('phys',id_phys)
-    CALL register_id('adv',id_adv)
-    CALL register_id('diags',id_diags)
-
-    CALL init_caldyn
-    
-!    IF (xios_output) itau_out=1
-    IF (.NOT. enable_io) itau_out=HUGE(itau_out)
-
-    itau_prof=100
-    CALL getin('itau_profiling',itau_prof)
-
-    positive_theta=.FALSE.
-    CALL getin('positive_theta',positive_theta)
-    IF(positive_theta .AND. nqtot<1) THEN
-       PRINT *, 'nqtot must be >0 if positive_theta is .TRUE.'
-       STOP
-    END IF
-
-    def='ARK2.3'
-    CALL getin('time_scheme',def)
-    SELECT CASE (TRIM(def))
-    CASE('euler')
-       scheme_family=explicit
-       scheme=euler
-       nb_stage=1
-    CASE ('runge_kutta')
-       scheme_family=explicit
-       scheme=rk4
-       nb_stage=4
-    CASE ('RK2.5')
-       scheme_family=explicit
-       scheme=rk25
-       nb_stage=5
-    CASE ('leapfrog_matsuno')
-       scheme_family=explicit
-       scheme=mlf
-       matsuno_period=5
-       CALL getin('matsuno_period',matsuno_period)
-       nb_stage=matsuno_period+1
-    CASE('ARK2.3')
-       scheme_family=hevi
-       scheme=ark23
-       nb_stage=3
-       CALL set_coefs_ark23(dt)
-    CASE('ARK3.3')
-       scheme_family=hevi
-       scheme=ark33
-       nb_stage=3
-       CALL set_coefs_ark33(dt)
-    CASE ('none')
-       nb_stage=0
-    CASE default
-       PRINT*,'Bad selector for variable scheme : <', TRIM(def),             &
-            ' > options are <euler>, <runge_kutta>, <leapfrog_matsuno>,<RK2.5>,<ARK2.3>'
-       STOP
-    END SELECT
-    
-    ! Time-independant orography
-    CALL allocate_field(f_phis,field_t,type_real,name='phis')
-    ! Model state at current time step
-    CALL allocate_field(f_ps,field_t,type_real, name='ps')
-    CALL allocate_field(f_mass,field_t,type_real,llm,name='mass')
-    CALL allocate_field(f_rhodz,field_t,type_real,llm,name='rhodz')
-    CALL allocate_field(f_theta_rhodz,field_t,type_real,llm,nqdyn,name='theta_rhodz')
-    CALL allocate_field(f_u,field_u,type_real,llm,name='u')
-    CALL allocate_field(f_geopot,field_t,type_real,llm+1,name='geopot')
-    CALL allocate_field(f_W,field_t,type_real,llm+1,name='W')
-    CALL allocate_field(f_q,field_t,type_real,llm,nqtot,'q')
-    ! Mass fluxes
-    CALL allocate_field(f_hflux,field_u,type_real,llm)    ! instantaneous mass fluxes
-    CALL allocate_field(f_hfluxt,field_u,type_real,llm)   ! mass "fluxes" accumulated in time
-    CALL allocate_field(f_wflux,field_t,type_real,llm+1)  ! vertical mass fluxes
-    CALL allocate_field(f_wfluxt,field_t,type_real,llm+1,name='wfluxt')
-    
-    SELECT CASE(scheme_family)
-    CASE(explicit)
-       ! Trends
-       CALL allocate_field(f_dps,field_t,type_real,name='dps')
-       CALL allocate_field(f_dmass,field_t,type_real,llm, name='dmass')
-       CALL allocate_field(f_dtheta_rhodz,field_t,type_real,llm,nqdyn,name='dtheta_rhodz')
-       CALL allocate_field(f_du,field_u,type_real,llm,name='du')
-       ! Model state at previous time step (RK/MLF)
-       CALL allocate_field(f_psm1,field_t,type_real,name='psm1')
-       CALL allocate_field(f_massm1,field_t,type_real,llm, name='massm1')
-       CALL allocate_field(f_theta_rhodzm1,field_t,type_real,llm,nqdyn,name='theta_rhodzm1')
-       CALL allocate_field(f_um1,field_u,type_real,llm,name='um1')
-    CASE(hevi)
-       ! Trends
-       CALL allocate_fields(nb_stage,f_dps_slow, field_t,type_real,name='dps_slow')
-       CALL allocate_fields(nb_stage,f_dmass_slow, field_t,type_real,llm, name='dmass_slow')
-       CALL allocate_fields(nb_stage,f_dtheta_rhodz_slow, field_t,type_real,llm,nqdyn,name='dtheta_rhodz_fast')
-       CALL allocate_fields(nb_stage,f_du_slow, field_u,type_real,llm,name='du_slow')
-       CALL allocate_fields(nb_stage,f_du_fast, field_u,type_real,llm,name='du_fast')
-       CALL allocate_fields(nb_stage,f_dW_slow, field_t,type_real,llm+1,name='dW_slow')
-       CALL allocate_fields(nb_stage,f_dW_fast, field_t,type_real,llm+1,name='dW_fast')
-       CALL allocate_fields(nb_stage,f_dPhi_slow, field_t,type_real,llm+1,name='dPhi_slow')
-       CALL allocate_fields(nb_stage,f_dPhi_fast, field_t,type_real,llm+1,name='dPhi_fast')
-       f_dps => f_dps_slow(:,1)
-       f_du => f_du_slow(:,1)
-       f_dtheta_rhodz => f_dtheta_rhodz_slow(:,1)
-    END SELECT
-
-    SELECT CASE(scheme)
-    CASE(mlf)
-       ! Model state 2 time steps ago (MLF)
-       CALL allocate_field(f_psm2,field_t,type_real)
-       CALL allocate_field(f_massm2,field_t,type_real,llm)
-       CALL allocate_field(f_theta_rhodzm2,field_t,type_real,llm,nqdyn)
-       CALL allocate_field(f_um2,field_u,type_real,llm)
-    END SELECT
-
-    CALL init_theta2theta_rhodz
-    CALL init_dissip
-    CALL init_sponge
-    CALL init_observable
-    CALL init_guided
-    CALL init_advect_tracer
-    CALL init_check_conserve
-
-    CALL etat0(f_ps,f_mass,f_phis,f_theta_rhodz,f_u, f_geopot,f_W, f_q)
-
-    CALL transfert_request(f_phis,req_i0) 
-    CALL transfert_request(f_phis,req_i1) 
-
-    CALL init_message(f_ps,req_i0,req_ps0)
-    CALL init_message(f_mass,req_i0,req_mass0)
-    CALL init_message(f_theta_rhodz,req_i0,req_theta_rhodz0)
-    CALL init_message(f_u,req_e0_vect,req_u0)
-    CALL init_message(f_q,req_i0,req_q0)
-    CALL init_message(f_geopot,req_i0,req_geopot0)
-    CALL init_message(f_W,req_i0,req_W0)
-
-  END SUBROUTINE init_timeloop
-  
-  SUBROUTINE timeloop
-    USE dissip_gcm_mod
-    USE sponge_mod
-    USE observable_mod
-    USE etat0_mod
-    USE guided_mod
-    USE caldyn_mod
-    USE advect_tracer_mod
-    USE diagflux_mod
-    USE physics_mod
-    USE mpipara
-    USE transfert_mod
-    USE check_conserve_mod
-    USE xios_mod
-    USE output_field_mod
-    USE write_etat0_mod
-    USE restart_mod
-    USE checksum_mod
-    USE explicit_scheme_mod
-    USE hevi_scheme_mod
-    REAL(rstd),POINTER :: rhodz(:,:), mass(:,:), ps(:)
-
-    REAL(rstd) :: adv_over_out ! ratio itau_adv/itau_out
-    INTEGER :: ind, it,l
-    LOGICAL :: fluxt_zero(ndomain) ! set to .TRUE. to start accumulating mass fluxes in time
-    LOGICAL, PARAMETER :: check_rhodz=.FALSE.
-    INTEGER(kind=8) :: start_clock, stop_clock, rate_clock
-    LOGICAL,SAVE :: first_physic=.TRUE.
-    !$OMP THREADPRIVATE(first_physic)    
-
-    CALL switch_omp_distrib_level
-    CALL caldyn_BC(f_phis, f_geopot, f_wflux) ! set constant values in first/last interfaces
-
-    !$OMP BARRIER
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       rhodz=f_rhodz(ind); mass=f_mass(ind); ps=f_ps(ind)
-       IF(caldyn_eta==eta_mass) THEN
-          CALL compute_rhodz(.TRUE., ps, rhodz) ! save rhodz for transport scheme before dynamics update ps
-       ELSE
-          DO l=ll_begin,ll_end
-             rhodz(:,l)=mass(:,l)
-          ENDDO
-       END IF
-    END DO
-    !$OMP BARRIER
-    fluxt_zero=.TRUE.
-
-    IF(positive_theta) CALL copy_theta_to_q(f_theta_rhodz,f_rhodz,f_q)
-    IF(diagflux_on) THEN
-       adv_over_out = itau_adv*(1./itau_out)
-    ELSE
-       adv_over_out = 0.
-    END IF
-
-    CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,itau0)  
-
-    Call trace_on
-
-    IF (xios_output) THEN ! we must call update_calendar before any XIOS output
-      IF (is_omp_master) CALL xios_update_calendar(1)
-    END IF
-    
-!    IF (write_start) CALL write_etat0(itau0,f_ps, f_phis,f_theta_rhodz,f_u,f_q)
-    IF (write_start) CALL write_etat0(itau0,f_ps, f_phis,f_theta_rhodz,f_u,f_q, f_geopot, f_W)
-   
-    CALL write_output_fields_basic(.TRUE., f_phis, f_ps, f_mass, f_geopot, f_theta_rhodz, f_u, f_W, f_q)
-
-    !$OMP MASTER
-    CALL SYSTEM_CLOCK(start_clock, rate_clock)
-    !$OMP END MASTER   
-
-    DO it=itau0+1,itau0+itaumax
-       IF (is_master) CALL print_iteration(it, itau0, itaumax, start_clock, rate_clock)
-
-       CALL enter_profile(id_timeloop)
-
-       IF (xios_output) THEN
-
-          IF(it>itau0+1 .AND. is_omp_master) CALL xios_update_calendar(it-itau0)
-       ELSE
-          CALL update_time_counter(dt*it)
-       END IF
-
-       IF (it==itau0+1 .OR. MOD(it,itau_sync)==0) THEN
-          CALL send_message(f_ps,req_ps0)
-          CALL wait_message(req_ps0)
-          CALL send_message(f_mass,req_mass0)
-          CALL wait_message(req_mass0)
-          CALL send_message(f_theta_rhodz,req_theta_rhodz0) 
-          CALL wait_message(req_theta_rhodz0) 
-          CALL send_message(f_u,req_u0)
-          CALL wait_message(req_u0)
-          CALL send_message(f_q,req_q0) 
-          CALL wait_message(req_q0)
-          IF(.NOT. hydrostatic) THEN
-             CALL send_message(f_geopot,req_geopot0)
-             CALL wait_message(req_geopot0)
-             CALL send_message(f_W,req_W0)
-             CALL wait_message(req_W0)
-          END IF
-       ENDIF
-
-       CALL guided(it*dt,f_ps,f_theta_rhodz,f_u,f_q)
-
-       CALL enter_profile(id_dyn)
-       SELECT CASE(scheme_family)
-       CASE(explicit)
-          CALL explicit_scheme(it, fluxt_zero)
-       CASE(hevi)
-          CALL HEVI_scheme(it, fluxt_zero)
-       END SELECT
-       CALL exit_profile(id_dyn)
-
-       CALL enter_profile(id_dissip)
-       IF (MOD(it,itau_dissip)==0) THEN
-          
-          IF(caldyn_eta==eta_mass) THEN
-             !ym flush ps
-             !$OMP BARRIER
-             DO ind=1,ndomain
-                IF (.NOT. assigned_domain(ind)) CYCLE
-                CALL swap_dimensions(ind)
-                CALL swap_geometry(ind)
-                mass=f_mass(ind); ps=f_ps(ind);
-                CALL compute_rhodz(.TRUE., ps, mass)
-             END DO
-          ENDIF
-          
-          CALL enter_profile(id_diags)
-          CALL check_conserve_detailed(it, AAM_dyn, &
-               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-          CALL exit_profile(id_diags)
-       
-          CALL dissip(f_ps,f_mass,f_phis,f_geopot,f_theta_rhodz,f_u, f_dtheta_rhodz,f_du)
-          
-          CALL euler_scheme(.FALSE.)  ! update only u, theta
-          IF (iflag_sponge > 0) THEN
-             CALL sponge(f_u,f_du,f_theta_rhodz,f_dtheta_rhodz)
-             CALL euler_scheme(.FALSE.)  ! update only u, theta
-          END IF
-
-          CALL enter_profile(id_diags)
-          CALL check_conserve_detailed(it, AAM_dissip, &
-               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-          CALL exit_profile(id_diags)
-       END IF
-       CALL exit_profile(id_dissip)
-       
-       CALL enter_profile(id_adv)
-       IF(MOD(it,itau_adv)==0) THEN
-          CALL advect_tracer(f_hfluxt,f_wfluxt,f_u, f_q,f_rhodz, & ! update q and rhodz after RK step
-               adv_over_out, f_masst,f_qmasst,f_massfluxt, f_qfluxt)  ! accumulate mass and fluxes if diagflux_on
-          fluxt_zero=.TRUE. ! restart accumulation of hfluxt and qfluxt at next call to explicit_scheme / HEVI_scheme
-          ! At this point advect_tracer has obtained the halos of u and rhodz,
-          ! needed for correct computation of kinetic energy
-          IF(diagflux_on) CALL diagflux_energy(adv_over_out, f_phis,f_rhodz,f_theta_rhodz,f_u, f_geopot,f_theta,f_buf_i, f_hfluxt)
-
-          IF (check_rhodz) THEN ! check that rhodz is consistent with ps
-             DO ind=1,ndomain
-                IF (.NOT. assigned_domain(ind)) CYCLE
-                CALL swap_dimensions(ind)
-                CALL swap_geometry(ind)
-                rhodz=f_rhodz(ind); ps=f_ps(ind);
-                CALL compute_rhodz(.FALSE., ps, rhodz)   
-             END DO
-          ENDIF
-          IF(positive_theta) CALL copy_q_to_theta(f_theta_rhodz,f_rhodz,f_q)
-       END IF
-       CALL exit_profile(id_adv)
-       
-       CALL enter_profile(id_diags)
-!       IF (MOD(it,itau_physics)==0) THEN
-          CALL check_conserve_detailed(it, AAM_dyn, &
-            f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-          CALL enter_profile(id_phys)
-          CALL physics(it,f_phis, f_ps, f_theta_rhodz, f_u, f_wflux, f_q)        
-          CALL exit_profile(id_phys)
-          CALL check_conserve_detailed(it, AAM_phys, &
-               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-          !$OMP MASTER
-          IF (first_physic) CALL SYSTEM_CLOCK(start_clock)
-          !$OMP END MASTER   
-          first_physic=.FALSE.
-!       END IF
-
-       IF (MOD(it,itau_check_conserv)==0) THEN
-          CALL check_conserve_detailed(it, AAM_dyn, &
-               f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-          CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,it) 
-       ENDIF
-
-       IF (mod(it,itau_out)==0 ) THEN
-          CALL transfert_request(f_u,req_e1_vect)
-          CALL write_output_fields_basic(.FALSE.,f_phis, f_ps, f_mass, f_geopot, f_theta_rhodz, f_u, f_W, f_q)
-       ENDIF
-       CALL exit_profile(id_diags)
-
-       CALL exit_profile(id_timeloop)
-    END DO
-    
-!    CALL write_etat0(itau0+itaumax,f_ps, f_phis,f_theta_rhodz,f_u,f_q) 
-    CALL write_etat0(itau0+itaumax,f_ps, f_phis,f_theta_rhodz,f_u,f_q, f_geopot, f_W) 
-    
-    CALL check_conserve_detailed(it, AAM_dyn, &
-         f_ps,f_dps,f_u,f_theta_rhodz,f_phis)
-    CALL check_conserve(f_ps,f_dps,f_u,f_theta_rhodz,f_phis,f_q,it)  
-    
-    !$OMP MASTER
-    CALL SYSTEM_CLOCK(stop_clock)
-    
-    IF (mpi_rank==0) THEN 
-       PRINT *,"Time elapsed : ",(stop_clock-start_clock)*1./rate_clock 
-    ENDIF
-    !$OMP END MASTER 
-    
-    ! CONTAINS
-  END SUBROUTINE timeloop
-
-  SUBROUTINE print_iteration(it,itau0,itaumax,start_clock,rate_clock)
-    INTEGER :: it, itau0, itaumax, throughput
-    INTEGER(kind=8) :: start_clock, stop_clock, rate_clock
-    REAL :: per_step,total, elapsed
-    WRITE(*,'(A,I7,A,F14.1)') "It No :",it,"   t :",dt*it
-    IF(MOD(it,10)==0) THEN
-       CALL SYSTEM_CLOCK(stop_clock)
-       elapsed = (stop_clock-start_clock)*1./rate_clock
-       per_step = elapsed/(it-itau0)
-       throughput = INT(dt/per_step)
-       total = per_step*itaumax
-       WRITE(*,'(A,I5,A,F6.2,A,I6)') 'Time spent (s):',INT(elapsed), &
-            '  -- ms/step : ', 1000*per_step, &
-            '  -- Throughput :', throughput
-       WRITE(*,'(A,I5,A,I5)') 'Whole job (min) :', INT(total/60.), &
-            '  -- Completion in (min) : ', INT((total-elapsed)/60.)
-    END IF
-    IF(MOD(it,itau_prof)==0) CALL print_profile
-
-  END SUBROUTINE print_iteration
-
-  SUBROUTINE copy_theta_to_q(f_theta_rhodz,f_rhodz,f_q)
-    TYPE(t_field),POINTER :: f_theta_rhodz(:),f_rhodz(:), f_q(:)
-    REAL(rstd), POINTER :: theta_rhodz(:,:,:), rhodz(:,:), q(:,:,:)
-    INTEGER :: ind, iq
-    DO ind=1, ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       theta_rhodz=f_theta_rhodz(ind)
-       rhodz=f_rhodz(ind)
-       q=f_q(ind)
-       DO iq=1, nqdyn
-          q(:,:,iq)  = theta_rhodz(:,:,iq)/rhodz(:,:)
-       END DO
-    END DO
-  END SUBROUTINE copy_theta_to_q
-
-  SUBROUTINE copy_q_to_theta(f_theta_rhodz,f_rhodz,f_q)
-    TYPE(t_field),POINTER :: f_theta_rhodz(:),f_rhodz(:), f_q(:)
-    REAL(rstd), POINTER :: theta_rhodz(:,:,:), rhodz(:,:), q(:,:,:)
-    INTEGER :: ind, iq
-    DO ind=1, ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       theta_rhodz=f_theta_rhodz(ind)
-       rhodz=f_rhodz(ind)
-       q=f_q(ind)
-       DO iq=1,nqdyn
-          theta_rhodz(:,:,iq) = rhodz(:,:)*q(:,:,iq)
-       END DO
-    END DO
-  END SUBROUTINE copy_q_to_theta
-
-END MODULE timeloop_gcm_mod
Index: codes/icosagcm/trunk/src/transport/advect.F90
===================================================================
--- codes/icosagcm/trunk/src/transport/advect.F90	(revision 926)
+++ codes/icosagcm/trunk/src/transport/advect.F90	(revision 953)
@@ -49,5 +49,5 @@
   !=======================================================================================
 
-  SUBROUTINE compute_gradq3d(qi,sqrt_leng,gradq3d,xyz_i,xyz_v)
+  SUBROUTINE compute_gradq3d(qi,sqrt_leng,gradq3d,xyz_i, xyz_v)
     USE trace
     USE omp_para
@@ -68,5 +68,5 @@
     REAL(rstd) :: x1,x2,x3
     REAL(rstd) :: dq(3)
-
+    
     CALL trace_start("compute_gradq3d1")
 
@@ -86,5 +86,8 @@
 !    END DO
 
-     DO l = ll_begin,ll_end 
+     !$acc data create(gradtri(:,:,:), arr(:), ar(:)) present(sqrt_leng(:), xyz_i(:,:), xyz_v(:,:), qi(:,:), gradq3d(:,:,:)) async
+
+     !$acc parallel loop collapse(2) async private(A, dq)
+     DO l = ll_begin,ll_end
 !DIR$ SIMD
       DO ij=ij_begin_ext,ij_end_ext
@@ -151,5 +154,8 @@
         
       ENDDO
+     ENDDO
       
+     !$acc parallel loop collapse(2) async private(A, dq)
+     DO l = ll_begin,ll_end
       DO ij=ij_begin_ext,ij_end_ext
 
@@ -219,4 +225,5 @@
 
 !DIR$ SIMD
+    !$acc parallel loop async
     DO ij=ij_begin,ij_end
        ar(ij) = arr(ij+z_up)+arr(ij+z_lup)+arr(ij+z_ldown)+arr(ij+z_down)+arr(ij+z_rdown)+arr(ij+z_rup)+1.e-50
@@ -225,4 +232,5 @@
     CALL trace_start2("compute_gradq3d2")
       
+    !$acc parallel loop collapse(3) async
     DO k=1,3
       DO l =ll_begin,ll_end
@@ -239,4 +247,5 @@
 
     !============================================================================================= LIMITING 
+    !$acc parallel loop collapse(2) async
     DO l =ll_begin,ll_end
 !DIR$ SIMD
@@ -251,8 +260,16 @@
              minq = min(qi(ij,l),qi(ij+t_right,l),qi(ij+t_lup,l),qi(ij+t_rup,l),qi(ij+t_left,l), &
                   qi(ij+t_rdown,l),qi(ij+t_ldown,l))
-             alphamx = (maxq - qi(ij,l)) ; alphamx = alphamx/(maxq_c - qi(ij,l) )
-             alphamx = max(alphamx,0.0)
-             alphami = (minq - qi(ij,l)); alphami = alphami/(minq_c - qi(ij,l))
-             alphami = max(alphami,0.0) 
+             IF ((maxq_c - qi(ij,l)) /= 0.0) THEN
+               alphamx = (maxq - qi(ij,l)) ; alphamx = alphamx/(maxq_c - qi(ij,l) )
+               alphamx = max(alphamx,0.0)
+             ELSE
+               alphamx = 0.0
+             ENDIF
+             IF ((minq_c - qi(ij,l)) /= 0.0) THEN
+               alphami = (minq - qi(ij,l)); alphami = alphami/(minq_c - qi(ij,l))
+               alphami = max(alphami,0.0)
+             ELSE
+               alphami = 0.0
+             ENDIF
              alpha   = min(alphamx,alphami,1.0)
 !             gradq3d(ij,l,:) = alpha*gradq3d(ij,l,:)
@@ -264,4 +281,6 @@
 
   CALL trace_end("compute_gradq3d3")
+
+  !$acc end data
   
   CONTAINS
@@ -329,5 +348,6 @@
 
   ! Backward trajectories, for use with Miura approach
-  SUBROUTINE compute_backward_traj(normal,tangent,ue,tau, cc)
+  SUBROUTINE compute_backward_traj(normal,tangent,ue,tau,cc)
+    USE geometry, ONLY : xyz_e, de, wee, le
     USE trace
     USE omp_para
@@ -345,6 +365,9 @@
 
     ! TODO : compute normal displacement ue*tau as hfluxt / mass(upwind) then reconstruct tangential displacement
-    
+
+    !$acc data present(ue(:,:), cc(:,:,:), normal(:,:), tangent(:,:), xyz_e(:,:), de(:), wee(:,:,:), le(:)) async
+
     ! reconstruct tangential wind then 3D wind at edge then cc = edge midpoint - u*tau
+    !$acc parallel loop private(up_e, v_e) collapse(2) gang vector async
     DO l = ll_begin,ll_end
 !DIR$ SIMD
@@ -397,5 +420,5 @@
        ENDDO
     END DO
-
+    !$acc end data
     CALL trace_end("compute_backward_traj")
 
@@ -404,7 +427,9 @@
   ! Horizontal transport (S. Dubey, T. Dubos)
   ! Slope-limited van Leer approach with hexagons
-  SUBROUTINE compute_advect_horiz(update_mass,diagflux_on, hfluxt,cc,gradq3d, mass,qi,qfluxt)
+  SUBROUTINE compute_advect_horiz(update_mass,diagflux_on, hfluxt,cc,gradq3d, mass, qi, qfluxt)
     USE trace
     USE omp_para
+    USE abort_mod
+    USE geometry, only : Ai, xyz_i
     IMPLICIT NONE
     LOGICAL, INTENT(IN)       :: update_mass, diagflux_on
@@ -415,12 +440,16 @@
     REAL(rstd), INTENT(INOUT) :: qi(iim*jjm,llm)
     REAL(rstd), INTENT(INOUT) :: qfluxt(3*iim*jjm,MERGE(llm,1,diagflux_on)) ! time-integrated tracer flux
-
-    REAL(rstd) :: dq,dmass,qe, newmass
+! metrics terms
+    
+    REAL(rstd) :: dq,dmass,qe,newmass
     REAL(rstd) :: qflux(3*iim*jjm,llm)
-    INTEGER :: ij,l
+    INTEGER :: ij,l,ij_tmp
+
+    IF(diagflux_on) CALL abort_acc("compute_advect_horiz : diagflux_on")
 
     CALL trace_start("compute_advect_horiz")
 #include "../kernels/advect_horiz.k90"
     CALL trace_end("compute_advect_horiz")
+
   END SUBROUTINE compute_advect_horiz
 
Index: codes/icosagcm/trunk/src/transport/advect_tracer.F90
===================================================================
--- codes/icosagcm/trunk/src/transport/advect_tracer.F90	(revision 953)
+++ codes/icosagcm/trunk/src/transport/advect_tracer.F90	(revision 953)
@@ -0,0 +1,362 @@
+MODULE advect_tracer_mod
+  USE icosa
+  USE advect_mod
+  IMPLICIT NONE
+  PRIVATE
+
+  TYPE(t_field),SAVE,POINTER :: f_normal(:)
+  TYPE(t_field),SAVE,POINTER :: f_tangent(:)
+  TYPE(t_field),SAVE,POINTER :: f_gradq3d(:)
+  TYPE(t_field),SAVE,POINTER :: f_cc(:)  ! starting point of backward-trajectory (Miura approach)
+  TYPE(t_field),SAVE,POINTER :: f_sqrt_leng(:)
+
+  TYPE(t_message),SAVE :: req_u, req_cc, req_wfluxt, req_q, req_rhodz, req_gradq3d
+
+  REAL(rstd), PARAMETER :: pente_max=2.0 ! for vlz
+
+! temporary shared variable for vlz
+  TYPE(t_field),SAVE,POINTER :: f_dzqw(:)   ! vertical finite difference of q 
+  TYPE(t_field),SAVE,POINTER :: f_adzqw(:)  ! abs(dzqw)
+  TYPE(t_field),SAVE,POINTER :: f_dzq(:)    ! limited slope of q
+  TYPE(t_field),SAVE,POINTER :: f_wq(:)     ! time-integrated flux of q
+
+  PUBLIC init_advect_tracer, advect_tracer
+
+CONTAINS
+
+  SUBROUTINE init_advect_tracer
+    USE omp_para
+    REAL(rstd),POINTER :: tangent(:,:)
+    REAL(rstd),POINTER :: normal(:,:)
+    REAL(rstd),POINTER :: sqrt_leng(:)
+    INTEGER :: ind
+
+    CALL allocate_field(f_normal,field_u,type_real,3, name='normal',ondevice=.TRUE.)
+    CALL allocate_field(f_tangent,field_u,type_real,3, name='tangent',ondevice=.TRUE.)
+    CALL allocate_field(f_gradq3d,field_t,type_real,llm,3, name='gradq3d',ondevice=.TRUE.)
+    CALL allocate_field(f_cc,field_u,type_real,llm,3, name='cc',ondevice=.TRUE.)
+    CALL allocate_field(f_sqrt_leng,field_t,type_real, name='sqrt_leng',ondevice=.TRUE.)
+    CALL allocate_field(f_dzqw, field_t, type_real, llm, name='dzqw',ondevice=.TRUE.)
+    CALL allocate_field(f_adzqw, field_t, type_real, llm, name='adzqw',ondevice=.TRUE.)
+    CALL allocate_field(f_dzq, field_t, type_real, llm, name='dzq',ondevice=.TRUE.)
+    CALL allocate_field(f_wq, field_t, type_real, llm+1, name='wq',ondevice=.TRUE.)
+    
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       normal=f_normal(ind)
+       tangent=f_tangent(ind)
+       sqrt_leng=f_sqrt_leng(ind)
+       IF (is_omp_level_master) CALL init_advect(normal,tangent,sqrt_leng)
+    END DO
+
+    CALL update_device_field(f_tangent)
+    CALL update_device_field(f_normal)
+    CALL update_device_field(f_sqrt_leng)
+
+  END SUBROUTINE init_advect_tracer
+
+  SUBROUTINE advect_tracer(f_hfluxt, f_wfluxt,f_u, f_q,f_rhodz,&
+       frac, f_masst,f_qmasst,f_massfluxt,f_qfluxt)
+    USE omp_para
+    USE trace
+    USE write_field_mod
+    USE tracer_mod
+    USE abort_mod
+    TYPE(t_field),POINTER :: f_hfluxt(:)   ! time-integrated horizontal mass flux
+    TYPE(t_field),POINTER :: f_wfluxt(:)   ! time-integrated vertical mass flux
+    TYPE(t_field),POINTER :: f_u(:)        ! velocity (for back-trajectories)
+    TYPE(t_field),POINTER :: f_q(:)        ! tracer
+    TYPE(t_field),POINTER :: f_rhodz(:)    ! mass field at beginning of macro time step
+    REAL(rstd), INTENT(in):: frac          ! ratio itau_adv/itau_out or 0. if not diagflux_on
+    TYPE(t_field),POINTER :: f_masst(:)    ! time-integrated mass
+    TYPE(t_field),POINTER :: f_qmasst(:)   ! time-integrated tracer mass
+    TYPE(t_field),POINTER :: f_massfluxt(:)! time-integrated horizontal mass flux
+    TYPE(t_field),POINTER :: f_qfluxt(:)   ! time-integrated horizontal tracer flux
+
+    REAL(rstd),POINTER :: q(:,:,:), normal(:,:), tangent(:,:), sqrt_leng(:), gradq3d(:,:,:), cc(:,:,:)
+    REAL(rstd),POINTER :: hfluxt(:,:), wfluxt(:,:), masst(:,:), qmasst(:,:,:), massfluxt(:,:), qfluxt(:,:,:)
+    REAL(rstd),POINTER :: rhodz(:,:), u(:,:) 
+! temporary shared variable for vlz
+    REAL(rstd),POINTER ::  dzqw(:,:)         ! vertical finite difference of q 
+    REAL(rstd),POINTER ::  adzqw(:,:)        ! abs(dzqw)
+    REAL(rstd),POINTER ::  dzq(:,:)          ! limited slope of q
+    REAL(rstd),POINTER ::  wq(:,:)           ! time-integrated flux of q
+    
+    INTEGER :: ind,k, nq_last
+    LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+    IF (first) THEN
+      first=.FALSE.
+      CALL init_message(f_u,req_e1_vect,req_u, 'req_u')
+      CALL init_message(f_cc,req_e1_scal,req_cc, 'req_cc')
+      CALL init_message(f_wfluxt,req_i1,req_wfluxt, 'req_wfluxt')
+      CALL init_message(f_q,req_i1,req_q, 'req_q')
+      CALL init_message(f_rhodz,req_i1,req_rhodz, 'req_rhodz')
+      CALL init_message(f_gradq3d,req_i1,req_gradq3d, 'req_gradq3d')
+    ENDIF
+    
+!!$OMP BARRIER
+
+    IF(nqtot<1) RETURN
+    nq_last=-1
+    
+    DO k = 1, nqtot
+      IF (advection_scheme(k)==advect_vanleer) nq_last=k
+    ENDDO
+     
+    IF(nq_last<0) RETURN
+      
+    CALL trace_start("advect_tracer") 
+
+    CALL send_message(f_u,req_u)
+    CALL send_message(f_wfluxt,req_wfluxt)
+    CALL send_message(f_q,req_q)
+    CALL send_message(f_rhodz,req_rhodz)
+
+    CALL wait_message(req_u)
+    CALL wait_message(req_wfluxt)
+    CALL wait_message(req_q)
+    CALL wait_message(req_rhodz)
+    
+    ! 1/2 vertical transport + back-trajectories
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       normal  = f_normal(ind)
+       tangent = f_tangent(ind)
+       cc      = f_cc(ind)
+       u       = f_u(ind)
+       q       = f_q(ind)
+       rhodz   = f_rhodz(ind)
+       wfluxt  = f_wfluxt(ind) 
+       dzqw    = f_dzqw(ind)
+       adzqw   = f_adzqw(ind)
+       dzq     = f_dzq(ind)
+       wq      = f_wq(ind) 
+
+       DO k = 1, nqtot
+          IF (advection_scheme(k)==advect_vanleer) CALL vlz(k==nq_last,0.5, wfluxt,rhodz,q(:,:,k),1,dzqw, adzqw, dzq, wq)
+       END DO
+
+       CALL compute_backward_traj(tangent,normal,u,0.5*dt*itau_adv, cc)
+    END DO
+
+    CALL send_message(f_cc,req_cc)
+
+    ! horizontal transport - split in two to place transfer of gradq3d
+    DO k = 1, nqtot
+      IF (advection_scheme(k)==advect_vanleer) THEN
+       
+        DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind)) CYCLE
+          CALL swap_dimensions(ind)
+          CALL swap_geometry(ind)
+          q       = f_q(ind)
+          gradq3d = f_gradq3d(ind)
+          sqrt_leng=f_sqrt_leng(ind)
+          CALL compute_gradq3d(q(:,:,k),sqrt_leng,gradq3d,xyz_i,xyz_v)
+        END DO
+
+        CALL send_message(f_gradq3d,req_gradq3d)
+        CALL wait_message(req_cc)
+        CALL wait_message(req_gradq3d)
+
+        DO ind=1,ndomain
+          IF (.NOT. assigned_domain(ind)) CYCLE
+          CALL swap_dimensions(ind)
+          CALL swap_geometry(ind)
+          cc      = f_cc(ind)
+          q       = f_q(ind)
+          rhodz   = f_rhodz(ind)
+          hfluxt  = f_hfluxt(ind) 
+          qfluxt  = f_qfluxt(ind) 
+          gradq3d = f_gradq3d(ind)
+
+          IF(frac>0.) THEN ! accumulate mass, mass flux and tracer mass
+             CALL abort_acc("frac>0.")
+             qmasst  = f_qmasst(ind) 
+             !$acc kernels default(present) async
+             qmasst(:,ll_begin:ll_end,k) = qmasst(:,ll_begin:ll_end,k) + &
+                  frac*rhodz(:,ll_begin:ll_end)*q(:,ll_begin:ll_end,k)
+             !$acc end kernels
+             IF(k==nq_last) THEN
+                masst  = f_masst(ind)
+                massfluxt  = f_massfluxt(ind)
+                !$acc kernels default(present) async
+                masst(:,ll_begin:ll_end) = masst(:,ll_begin:ll_end)+frac*rhodz(:,ll_begin:ll_end)
+                massfluxt(:,ll_begin:ll_end) = massfluxt(:,ll_begin:ll_end)+hfluxt(:,ll_begin:ll_end)
+                !$acc end kernels
+             END IF
+          END IF
+          CALL compute_advect_horiz(k==nq_last,frac>0., hfluxt,cc,gradq3d, rhodz, q(:,:,k), qfluxt(:,:,k))
+        END DO
+
+      ENDIF
+    END DO 
+
+    ! 1/2 vertical transport
+!!$OMP BARRIER
+
+    DO ind=1,ndomain
+       IF (.NOT. assigned_domain(ind)) CYCLE
+       CALL swap_dimensions(ind)
+       CALL swap_geometry(ind)
+       q       = f_q(ind)
+       rhodz   = f_rhodz(ind)
+       wfluxt  = f_wfluxt(ind) 
+       dzqw    = f_dzqw(ind)
+       adzqw   = f_adzqw(ind)
+       dzq     = f_dzq(ind)
+       wq      = f_wq(ind) 
+
+       DO k = 1,nqtot
+         IF (advection_scheme(k)==advect_vanleer) CALL vlz(k==nq_last, 0.5,wfluxt,rhodz, q(:,:,k),0, dzqw, adzqw, dzq, wq)
+       END DO
+    END DO
+
+    CALL trace_end("advect_tracer")
+
+!!$OMP BARRIER
+
+  END SUBROUTINE advect_tracer
+
+  SUBROUTINE vlz(update_mass, fac,wfluxt,mass, q, halo, dzqw, adzqw, dzq, wq)
+    !
+    !     Auteurs:   P.Le Van, F.Hourdin, F.Forget, T. Dubos
+    !
+    !    ********************************************************************
+    !     Update tracers using vertical mass flux only
+    !     Van Leer scheme with minmod limiter
+    !     wfluxt >0 for upward transport
+    !    ********************************************************************
+    USE trace
+    USE omp_para
+    LOGICAL, INTENT(IN)       :: update_mass
+    REAL(rstd), INTENT(IN)    :: fac, wfluxt(iim*jjm,llm+1) ! vertical mass flux
+    REAL(rstd), INTENT(INOUT) :: mass(iim*jjm,llm)
+    REAL(rstd), INTENT(INOUT) :: q(iim*jjm,llm)
+    INTEGER, INTENT(IN) :: halo
+
+! temporary shared variable
+    REAL(rstd),INTENT(INOUT) :: dzqw(iim*jjm,llm),        & ! vertical finite difference of q 
+                                adzqw(iim*jjm,llm),       & ! abs(dzqw)
+                                dzq(iim*jjm,llm),         & ! limited slope of q
+                                wq(iim*jjm,llm+1)           ! time-integrated flux of q
+
+
+    REAL(rstd) :: dzqmax, newmass, sigw, qq, w
+    INTEGER :: ij,l,ijb,ije
+
+    CALL trace_start("vlz")
+     
+     ijb=((jj_begin-halo)-1)*iim+ii_begin-halo
+     ije = ((jj_end+halo)-1)*iim+ii_end+halo
+
+    ! finite difference of q
+
+     !$acc data present(q(:,:), mass(:,:), wfluxt(:,:), dzqw(:,:), adzqw(:,:), dzq(:,:), wq(:,:)) async
+
+     !$acc parallel loop async collapse(2)
+     DO l=ll_beginp1,ll_end
+!DIR$ SIMD
+       DO ij=ijb,ije
+         dzqw(ij,l)=q(ij,l)-q(ij,l-1)
+         adzqw(ij,l)=abs(dzqw(ij,l))
+       ENDDO
+    ENDDO
+
+!--> flush dzqw, adzqw
+!$OMP BARRIER
+
+    ! minmod-limited slope of q
+    ! dzq = slope*dz, i.e. the reconstructed q varies by dzq inside level l
+
+     !$acc parallel loop async collapse(2)
+     DO l=ll_beginp1,ll_endm1
+!DIR$ SIMD
+       DO ij=ijb,ije 
+         IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+             dzq(ij,l) = 0.5*( dzqw(ij,l)+dzqw(ij,l+1) )
+             dzqmax    = pente_max * min( adzqw(ij,l),adzqw(ij,l+1) )
+             dzq(ij,l) = sign( min(abs(dzq(ij,l)),dzqmax) , dzq(ij,l) )  ! NB : sign(a,b)=a*sign(b)
+          ELSE
+             dzq(ij,l)=0.
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+    ! 0 slope in top and bottom layers
+    IF (is_omp_first_level) THEN
+      !$acc parallel loop async
+      DO ij=ijb,ije
+           dzq(ij,1)=0.
+      ENDDO
+    ENDIF
+      
+    IF (is_omp_last_level) THEN
+      !$acc parallel loop async
+      DO ij=ijb,ije
+          dzq(ij,llm)=0.
+      ENDDO
+    ENDIF
+
+!---> flush dzq
+!$OMP BARRIER  
+
+    ! sigw = fraction of mass that leaves level l/l+1
+    ! then amount of q leaving level l/l+1 = wq = w * qq
+     !$acc parallel loop collapse(2) async
+     DO l=ll_beginp1,ll_end
+!DIR$ SIMD
+       DO ij=ijb,ije
+             w = fac*wfluxt(ij,l)
+             IF(w>0.) THEN  ! upward transport, upwind side is at level l 
+                sigw       = w/mass(ij,l-1)
+                qq         = q(ij,l-1)+0.5*(1.-sigw)*dzq(ij,l-1) ! qq = q if sigw=1 , qq = q+dzq/2 if sigw=0
+             ELSE           ! downward transport, upwind side is at level l+1
+                sigw       = w/mass(ij,l)
+                qq         = q(ij,l)-0.5*(1.+sigw)*dzq(ij,l) ! qq = q if sigw=-1 , qq = q-dzq/2 if sigw=0                
+             ENDIF
+             wq(ij,l) = w*qq
+       ENDDO
+    END DO
+    ! wq = 0 at top and bottom
+    IF (is_omp_first_level) THEN
+      !$acc parallel loop async
+       DO ij=ijb,ije
+            wq(ij,1)=0.
+      END DO
+    ENDIF
+    
+    IF (is_omp_last_level) THEN
+      !$acc parallel loop async
+      DO ij=ijb,ije
+            wq(ij,llm+1)=0.
+      END DO
+    ENDIF
+
+! --> flush wq
+!$OMP BARRIER
+
+
+    ! update q, mass is updated only after all q's have been updated
+    !$acc parallel loop collapse(2) async
+    DO l=ll_begin,ll_end
+!DIR$ SIMD
+       DO ij=ijb,ije
+             newmass = mass(ij,l) + fac*(wfluxt(ij,l)-wfluxt(ij,l+1))
+             q(ij,l) = ( q(ij,l)*mass(ij,l) + wq(ij,l)-wq(ij,l+1) ) / newmass
+             IF(update_mass) mass(ij,l)=newmass
+       ENDDO
+    END DO
+    !$acc end data
+    CALL trace_end("vlz")
+
+  END SUBROUTINE vlz
+
+END MODULE advect_tracer_mod
Index: codes/icosagcm/trunk/src/transport/advect_tracer.f90
===================================================================
--- codes/icosagcm/trunk/src/transport/advect_tracer.f90	(revision 926)
+++ 	(revision )
@@ -1,344 +1,0 @@
-MODULE advect_tracer_mod
-  USE icosa
-  USE advect_mod
-  IMPLICIT NONE
-  PRIVATE
-
-  TYPE(t_field),SAVE,POINTER :: f_normal(:)
-  TYPE(t_field),SAVE,POINTER :: f_tangent(:)
-  TYPE(t_field),SAVE,POINTER :: f_gradq3d(:)
-  TYPE(t_field),SAVE,POINTER :: f_cc(:)  ! starting point of backward-trajectory (Miura approach)
-  TYPE(t_field),SAVE,POINTER :: f_sqrt_leng(:)
-
-  TYPE(t_message),SAVE :: req_u, req_cc, req_wfluxt, req_q, req_rhodz, req_gradq3d
-
-  REAL(rstd), PARAMETER :: pente_max=2.0 ! for vlz
-
-! temporary shared variable for vlz
-  TYPE(t_field),SAVE,POINTER :: f_dzqw(:)   ! vertical finite difference of q 
-  TYPE(t_field),SAVE,POINTER :: f_adzqw(:)  ! abs(dzqw)
-  TYPE(t_field),SAVE,POINTER :: f_dzq(:)    ! limited slope of q
-  TYPE(t_field),SAVE,POINTER :: f_wq(:)     ! time-integrated flux of q
-
-  PUBLIC init_advect_tracer, advect_tracer
-
-CONTAINS
-
-  SUBROUTINE init_advect_tracer
-    USE omp_para
-    REAL(rstd),POINTER :: tangent(:,:)
-    REAL(rstd),POINTER :: normal(:,:)
-    REAL(rstd),POINTER :: sqrt_leng(:)
-    INTEGER :: ind
-
-    CALL allocate_field(f_normal,field_u,type_real,3, name='normal')
-    CALL allocate_field(f_tangent,field_u,type_real,3, name='tangent')
-    CALL allocate_field(f_gradq3d,field_t,type_real,llm,3, name='gradq3d')
-    CALL allocate_field(f_cc,field_u,type_real,llm,3, name='cc')
-    CALL allocate_field(f_sqrt_leng,field_t,type_real, name='sqrt_leng')
-    CALL allocate_field(f_dzqw, field_t, type_real, llm, name='dzqw')
-    CALL allocate_field(f_adzqw, field_t, type_real, llm, name='adzqw')
-    CALL allocate_field(f_dzq, field_t, type_real, llm, name='dzq')
-    CALL allocate_field(f_wq, field_t, type_real, llm+1, name='wq')
-    
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       normal=f_normal(ind)
-       tangent=f_tangent(ind)
-       sqrt_leng=f_sqrt_leng(ind)
-       IF (is_omp_level_master) CALL init_advect(normal,tangent,sqrt_leng)
-    END DO
-
-  END SUBROUTINE init_advect_tracer
-
-  SUBROUTINE advect_tracer(f_hfluxt, f_wfluxt,f_u, f_q,f_rhodz,&
-       frac, f_masst,f_qmasst,f_massfluxt,f_qfluxt)
-    USE omp_para
-    USE trace
-    USE write_field_mod
-    USE tracer_mod
-    TYPE(t_field),POINTER :: f_hfluxt(:)   ! time-integrated horizontal mass flux
-    TYPE(t_field),POINTER :: f_wfluxt(:)   ! time-integrated vertical mass flux
-    TYPE(t_field),POINTER :: f_u(:)        ! velocity (for back-trajectories)
-    TYPE(t_field),POINTER :: f_q(:)        ! tracer
-    TYPE(t_field),POINTER :: f_rhodz(:)    ! mass field at beginning of macro time step
-    REAL(rstd), INTENT(in):: frac          ! ratio itau_adv/itau_out or 0. if not diagflux_on
-    TYPE(t_field),POINTER :: f_masst(:)    ! time-integrated mass
-    TYPE(t_field),POINTER :: f_qmasst(:)   ! time-integrated tracer mass
-    TYPE(t_field),POINTER :: f_massfluxt(:)! time-integrated horizontal mass flux
-    TYPE(t_field),POINTER :: f_qfluxt(:)   ! time-integrated horizontal tracer flux
-
-    REAL(rstd),POINTER :: q(:,:,:), normal(:,:), tangent(:,:), sqrt_leng(:), gradq3d(:,:,:), cc(:,:,:)
-    REAL(rstd),POINTER :: hfluxt(:,:), wfluxt(:,:), masst(:,:), qmasst(:,:,:), massfluxt(:,:), qfluxt(:,:,:)
-    REAL(rstd),POINTER :: rhodz(:,:), u(:,:) 
-! temporary shared variable for vlz
-    REAL(rstd),POINTER ::  dzqw(:,:)         ! vertical finite difference of q 
-    REAL(rstd),POINTER ::  adzqw(:,:)        ! abs(dzqw)
-    REAL(rstd),POINTER ::  dzq(:,:)          ! limited slope of q
-    REAL(rstd),POINTER ::  wq(:,:)           ! time-integrated flux of q
-    
-    INTEGER :: ind,k, nq_last
-    LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-    IF (first) THEN
-      first=.FALSE.
-      CALL init_message(f_u,req_e1_vect,req_u, 'req_u')
-      CALL init_message(f_cc,req_e1_scal,req_cc, 'req_cc')
-      CALL init_message(f_wfluxt,req_i1,req_wfluxt, 'req_wfluxt')
-      CALL init_message(f_q,req_i1,req_q, 'req_q')
-      CALL init_message(f_rhodz,req_i1,req_rhodz, 'req_rhodz')
-      CALL init_message(f_gradq3d,req_i1,req_gradq3d, 'req_gradq3d')
-    ENDIF
-    
-!!$OMP BARRIER
-
-    IF(nqtot<1) RETURN
-    nq_last=-1
-    
-    DO k = 1, nqtot
-      IF (advection_scheme(k)==advect_vanleer) nq_last=k
-    ENDDO
-     
-    IF(nq_last<0) RETURN
-      
-    CALL trace_start("advect_tracer") 
-
-    CALL send_message(f_u,req_u)
-    CALL send_message(f_wfluxt,req_wfluxt)
-    CALL send_message(f_q,req_q)
-    CALL send_message(f_rhodz,req_rhodz)
-
-    CALL wait_message(req_u)
-    CALL wait_message(req_wfluxt)
-    CALL wait_message(req_q)
-    CALL wait_message(req_rhodz)
-    
-    ! 1/2 vertical transport + back-trajectories
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       normal  = f_normal(ind)
-       tangent = f_tangent(ind)
-       cc      = f_cc(ind)
-       u       = f_u(ind)
-       q       = f_q(ind)
-       rhodz   = f_rhodz(ind)
-       wfluxt  = f_wfluxt(ind) 
-       dzqw    = f_dzqw(ind)
-       adzqw   = f_adzqw(ind)
-       dzq     = f_dzq(ind)
-       wq      = f_wq(ind) 
-
-       DO k = 1, nqtot
-          IF (advection_scheme(k)==advect_vanleer) CALL vlz(k==nq_last,0.5, wfluxt,rhodz,q(:,:,k),1,dzqw, adzqw, dzq, wq)
-       END DO
-
-       CALL compute_backward_traj(tangent,normal,u,0.5*dt*itau_adv, cc) 
-
-    END DO
-
-    CALL send_message(f_cc,req_cc)
-
-    ! horizontal transport - split in two to place transfer of gradq3d
-    DO k = 1, nqtot
-      IF (advection_scheme(k)==advect_vanleer) THEN
-       
-        DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind)) CYCLE
-          CALL swap_dimensions(ind)
-          CALL swap_geometry(ind)
-          q       = f_q(ind)
-          gradq3d = f_gradq3d(ind)
-          sqrt_leng=f_sqrt_leng(ind)
-          CALL compute_gradq3d(q(:,:,k),sqrt_leng,gradq3d,xyz_i,xyz_v)
-        END DO
-
-        CALL send_message(f_gradq3d,req_gradq3d)
-        CALL wait_message(req_cc)
-        CALL wait_message(req_gradq3d)
-
-        DO ind=1,ndomain
-          IF (.NOT. assigned_domain(ind)) CYCLE
-          CALL swap_dimensions(ind)
-          CALL swap_geometry(ind)
-          cc      = f_cc(ind)
-          q       = f_q(ind)
-          rhodz   = f_rhodz(ind)
-          hfluxt  = f_hfluxt(ind) 
-          qfluxt  = f_qfluxt(ind) 
-          gradq3d = f_gradq3d(ind)
-
-          IF(frac>0.) THEN ! accumulate mass, mass flux and tracer mass
-             qmasst  = f_qmasst(ind) 
-             qmasst(:,ll_begin:ll_end,k) = qmasst(:,ll_begin:ll_end,k) + &
-                  frac*rhodz(:,ll_begin:ll_end)*q(:,ll_begin:ll_end,k)
-             IF(k==nq_last) THEN
-                masst  = f_masst(ind)
-                massfluxt  = f_massfluxt(ind)
-                masst(:,ll_begin:ll_end) = masst(:,ll_begin:ll_end)+frac*rhodz(:,ll_begin:ll_end)
-                massfluxt(:,ll_begin:ll_end) = massfluxt(:,ll_begin:ll_end)+hfluxt(:,ll_begin:ll_end)
-             END IF
-          END IF
-          CALL compute_advect_horiz(k==nq_last,frac>0., hfluxt,cc,gradq3d, rhodz, q(:,:,k), qfluxt(:,:,k))
-        END DO
-
-      ENDIF
-    END DO 
-    
-    ! 1/2 vertical transport
-!!$OMP BARRIER
-
-    DO ind=1,ndomain
-       IF (.NOT. assigned_domain(ind)) CYCLE
-       CALL swap_dimensions(ind)
-       CALL swap_geometry(ind)
-       q       = f_q(ind)
-       rhodz   = f_rhodz(ind)
-       wfluxt  = f_wfluxt(ind) 
-       dzqw    = f_dzqw(ind)
-       adzqw   = f_adzqw(ind)
-       dzq     = f_dzq(ind)
-       wq      = f_wq(ind) 
-
-       DO k = 1,nqtot
-         IF (advection_scheme(k)==advect_vanleer) CALL vlz(k==nq_last, 0.5,wfluxt,rhodz, q(:,:,k),0, dzqw, adzqw, dzq, wq)
-       END DO
-
-    END DO
-
-    CALL trace_end("advect_tracer")
-
-!!$OMP BARRIER
-
-  END SUBROUTINE advect_tracer
-
-  SUBROUTINE vlz(update_mass, fac,wfluxt,mass, q, halo, dzqw, adzqw, dzq, wq)
-    !
-    !     Auteurs:   P.Le Van, F.Hourdin, F.Forget, T. Dubos
-    !
-    !    ********************************************************************
-    !     Update tracers using vertical mass flux only
-    !     Van Leer scheme with minmod limiter
-    !     wfluxt >0 for upward transport
-    !    ********************************************************************
-    USE trace
-    USE omp_para
-    LOGICAL, INTENT(IN)       :: update_mass
-    REAL(rstd), INTENT(IN)    :: fac, wfluxt(iim*jjm,llm+1) ! vertical mass flux
-    REAL(rstd), INTENT(INOUT) :: mass(iim*jjm,llm)
-    REAL(rstd), INTENT(INOUT) :: q(iim*jjm,llm)
-    INTEGER, INTENT(IN) :: halo
-
-! temporary shared variable
-    REAL(rstd),INTENT(INOUT) :: dzqw(iim*jjm,llm),        & ! vertical finite difference of q 
-                                adzqw(iim*jjm,llm),       & ! abs(dzqw)
-                                dzq(iim*jjm,llm),         & ! limited slope of q
-                                wq(iim*jjm,llm+1)           ! time-integrated flux of q
-
-
-    REAL(rstd) :: dzqmax, newmass, sigw, qq, w
-    INTEGER :: ij,l,ijb,ije
-
-    CALL trace_start("vlz")
-     
-     ijb=((jj_begin-halo)-1)*iim+ii_begin-halo
-     ije = ((jj_end+halo)-1)*iim+ii_end+halo
-
-    ! finite difference of q
-
-     DO l=ll_beginp1,ll_end
-!DIR$ SIMD
-       DO ij=ijb,ije
-         dzqw(ij,l)=q(ij,l)-q(ij,l-1)
-         adzqw(ij,l)=abs(dzqw(ij,l))
-       ENDDO
-    ENDDO
-
-!--> flush dzqw, adzqw
-!$OMP BARRIER
-
-    ! minmod-limited slope of q
-    ! dzq = slope*dz, i.e. the reconstructed q varies by dzq inside level l
-
-     DO l=ll_beginp1,ll_endm1
-!DIR$ SIMD
-       DO ij=ijb,ije 
-         IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
-             dzq(ij,l) = 0.5*( dzqw(ij,l)+dzqw(ij,l+1) )
-             dzqmax    = pente_max * min( adzqw(ij,l),adzqw(ij,l+1) )
-             dzq(ij,l) = sign( min(abs(dzq(ij,l)),dzqmax) , dzq(ij,l) )  ! NB : sign(a,b)=a*sign(b)
-          ELSE
-             dzq(ij,l)=0.
-          ENDIF
-       ENDDO
-    ENDDO
-
-
-    ! 0 slope in top and bottom layers
-    IF (is_omp_first_level) THEN
-      DO ij=ijb,ije
-           dzq(ij,1)=0.
-      ENDDO
-    ENDIF
-      
-    IF (is_omp_last_level) THEN
-      DO ij=ijb,ije
-          dzq(ij,llm)=0.
-      ENDDO
-    ENDIF
-
-!---> flush dzq
-!$OMP BARRIER  
-
-    ! sigw = fraction of mass that leaves level l/l+1
-    ! then amount of q leaving level l/l+1 = wq = w * qq
-     DO l=ll_beginp1,ll_end
-!DIR$ SIMD
-       DO ij=ijb,ije
-             w = fac*wfluxt(ij,l)
-             IF(w>0.) THEN  ! upward transport, upwind side is at level l 
-                sigw       = w/mass(ij,l-1)
-                qq         = q(ij,l-1)+0.5*(1.-sigw)*dzq(ij,l-1) ! qq = q if sigw=1 , qq = q+dzq/2 if sigw=0
-             ELSE           ! downward transport, upwind side is at level l+1
-                sigw       = w/mass(ij,l)
-                qq         = q(ij,l)-0.5*(1.+sigw)*dzq(ij,l) ! qq = q if sigw=-1 , qq = q-dzq/2 if sigw=0                
-             ENDIF
-             wq(ij,l) = w*qq
-       ENDDO
-    END DO
-    ! wq = 0 at top and bottom
-    IF (is_omp_first_level) THEN
-       DO ij=ijb,ije
-            wq(ij,1)=0.
-      END DO
-    ENDIF
-    
-    IF (is_omp_last_level) THEN
-      DO ij=ijb,ije
-            wq(ij,llm+1)=0.
-      END DO
-    ENDIF
-
-! --> flush wq
-!$OMP BARRIER
-
-
-    ! update q, mass is updated only after all q's have been updated
-    DO l=ll_begin,ll_end
-!DIR$ SIMD
-       DO ij=ijb,ije
-             newmass = mass(ij,l) + fac*(wfluxt(ij,l)-wfluxt(ij,l+1))
-             q(ij,l) = ( q(ij,l)*mass(ij,l) + wq(ij,l)-wq(ij,l+1) ) / newmass
-             IF(update_mass) mass(ij,l)=newmass
-       ENDDO
-    END DO
-
-    CALL trace_end("vlz")
-
-  END SUBROUTINE vlz
-
-END MODULE advect_tracer_mod
Index: codes/icosagcm/trunk/src/vertical/disvert.f90
===================================================================
--- codes/icosagcm/trunk/src/vertical/disvert.f90	(revision 926)
+++ codes/icosagcm/trunk/src/vertical/disvert.f90	(revision 953)
@@ -1,4 +1,5 @@
 MODULE disvert_mod
   USE icosa
+  USE abort_mod
   REAL(rstd), SAVE, POINTER :: ap(:)
 !$OMP THREADPRIVATE(ap) 
@@ -146,7 +147,9 @@
     END IF
 
+    !$acc enter data copyin(ap(:), bp(:), mass_dak(:), mass_dbk(:)) async
+    
   END SUBROUTINE init_disvert  
   
-  SUBROUTINE compute_rhodz(comp, ps, rhodz)
+  SUBROUTINE compute_rhodz(comp, ps, rhodz, ondevice)
     USE icosa
     USE omp_para
@@ -154,7 +157,14 @@
     REAL(rstd), INTENT(IN) :: ps(iim*jjm)
     REAL(rstd), INTENT(INOUT) :: rhodz(iim*jjm,llm)
+    LOGICAL, INTENT(IN), OPTIONAL :: ondevice ! .TRUE. compute on device, .FALSE. stay on host
     REAL(rstd) :: m, err
     INTEGER :: l,i,j,ij,dd
+    LOGICAL :: ondevice_
+
     err=0.
+
+    ! by default, do not compute on device
+    ondevice_ = .FALSE.
+    IF (PRESENT(ondevice)) ondevice_ = ondevice
 
     IF(comp) THEN
@@ -164,15 +174,8 @@
     END IF
 
+    !$acc data present(ps(:), rhodz(:,:), ap(:), bp(:)) async if (ondevice_)
+
     IF(comp) THEN
-    DO l = ll_begin, ll_end
-       DO j=jj_begin-dd,jj_end+dd
-          DO i=ii_begin-dd,ii_end+dd
-             ij=(j-1)*iim+i
-             m = ( ap(l) - ap(l+1) + (bp(l)-bp(l+1))*ps(ij) )/g 
-                rhodz(ij,l) = m
-          ENDDO
-        ENDDO
-      ENDDO
-             ELSE
+      !$acc parallel loop collapse(3) async if (ondevice_)
       DO l = ll_begin, ll_end
         DO j=jj_begin-dd,jj_end+dd
@@ -180,10 +183,22 @@
             ij=(j-1)*iim+i
             m = ( ap(l) - ap(l+1) + (bp(l)-bp(l+1))*ps(ij) )/g
-                err = MAX(err,abs(m-rhodz(ij,l)))
+            rhodz(ij,l) = m
           ENDDO
-       ENDDO
-    ENDDO
-
-       IF(err>1e-10) THEN
+        ENDDO
+      ENDDO
+    ELSE
+      !$acc parallel loop reduction(max:err) collapse(3) async if (ondevice_)
+      DO l = ll_begin, ll_end
+        DO j=jj_begin-dd,jj_end+dd
+          DO i=ii_begin-dd,ii_end+dd
+            ij=(j-1)*iim+i
+            m = ( ap(l) - ap(l+1) + (bp(l)-bp(l+1))*ps(ij) )/g
+            err = MAX(err,abs(m-rhodz(ij,l)))
+          ENDDO
+        ENDDO
+      ENDDO
+
+      !$acc wait
+      IF(err>1e-10) THEN
           PRINT *, 'Discrepancy between ps and rhodz detected', err
           STOP
@@ -191,7 +206,8 @@
     ENDIF
 
+    !$acc end data
   END SUBROUTINE compute_rhodz
 
- 
+
   SUBROUTINE write_apbp
   USE icosa
