source: codes/icosagcm/branches/SATURN_DYNAMICO/ICOSAGCM/src/kinetic.f90 @ 314

MODULE kinetic_mod


CONTAINS
  
  SUBROUTINE kinetic(f_ue,f_Ki)
  USE icosa
  IMPLICIT NONE
    TYPE(t_field), POINTER :: f_ue(:)
    TYPE(t_field), POINTER :: f_Ki(:)
  
    REAL(rstd), POINTER :: ue(:,:)
    REAL(rstd), POINTER :: Ki(:,:)
    INTEGER :: ind
  
    CALL transfert_request(f_ue,req_e1_vect)
    CALL transfert_request(f_ue,req_e1_vect)

    DO ind=1,ndomain
      IF (.NOT. assigned_domain(ind)) CYCLE
      CALL swap_dimensions(ind)
      CALL swap_geometry(ind)
      ue=f_ue(ind)
      Ki=f_Ki(ind)
      CALL compute_kinetic(ue, Ki)
    ENDDO
  
  END SUBROUTINE kinetic
  
  SUBROUTINE compute_kinetic(ue, Ki)
  USE icosa
  IMPLICIT NONE
    REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm)
    REAL(rstd),INTENT(OUT) :: Ki(iim*jjm,llm)
    INTEGER :: i,j,ij,l
    
    DO l=1,llm
      DO j=jj_begin,jj_end
        DO i=ii_begin,ii_end
          ij=(j-1)*iim+i

          Ki(ij,l)=1/(4*Ai(ij))*(le(ij+u_right)*de(ij+u_right)*ue(ij+u_right,l)**2 +  &
                               le(ij+u_rup)*de(ij+u_rup)*ue(ij+u_rup,l)**2 +        &
                               le(ij+u_lup)*de(ij+u_lup)*ue(ij+u_lup,l)**2 +        &
                               le(ij+u_left)*de(ij+u_left)*ue(ij+u_left,l)**2 +     &
                               le(ij+u_ldown)*de(ij+u_ldown)*ue(ij+u_ldown,l)**2 +  &
                               le(ij+u_rdown)*de(ij+u_rdown)*ue(ij+u_rdown,l)**2 )  
       
        ENDDO
      ENDDO
    ENDDO
    
  
  END SUBROUTINE compute_kinetic
        
END MODULE kinetic_mod