source: LMDZ4/trunk/libf/phylmd/iophy.F90 @ 766

module iophy
  
  REAL,private,allocatable,dimension(:,:),save :: tmp_tab2d
  REAL,private,allocatable,dimension(:,:,:),save :: tmp_tab3d
  INTEGER,private,allocatable,dimension(:),save :: ndex2d
  INTEGER,private,allocatable,dimension(:),save :: ndex3d
  REAL,private,allocatable,dimension(:),save :: io_lat
  REAL,private,allocatable,dimension(:),save :: io_lon
  INTEGER, save :: phys_domain_id
  
  INTERFACE histwrite_phy
    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
  END INTERFACE 
  
  REAL,private,allocatable,save,dimension(:,:) :: buffer_omp

contains

  subroutine init_iophy(lat,lon)
  use dimphy
  use ioipsl
  implicit none
  include 'dimensions90.h'   
    real,dimension(iim),intent(in) :: lon
    real,dimension(jjm+1),intent(in) :: lat

    INTEGER,DIMENSION(2) :: ddid
    INTEGER,DIMENSION(2) :: dsg
    INTEGER,DIMENSION(2) :: dsl
    INTEGER,DIMENSION(2) :: dpf
    INTEGER,DIMENSION(2) :: dpl
    INTEGER,DIMENSION(2) :: dhs
    INTEGER,DIMENSION(2) :: dhe 

!$OMP MASTER  
    allocate(io_lat(jjm+1))
    io_lat(:)=lat(:)
    allocate(io_lon(iim))
    io_lon(:)=lon(:)
    allocate(tmp_tab2d(iim,jjphy_nb))
    allocate(tmp_tab3d(iim,jjphy_nb,klev))
    allocate(ndex2d(iim*jjphy_nb))
    allocate(ndex3d(iim*jjphy_nb*klev))
    ndex2d(:)=0
    ndex3d(:)=0
    allocate(buffer_omp(klon_mpi,klev))
    
    ddid=(/ 1,2 /)
    dsg=(/ iim, jjm+1 /)
    dsl=(/ iim, jjphy_nb /)
    dpf=(/ 1,jjphy_begin /)
    dpl=(/ iim, jjphy_end /)
    dhs=(/ iiphy_begin-1,0 /)
    if (phy_rank==phy_size-1) then
      dhe=(/0,0/)
    else
      dhe=(/ iim-iiphy_end,0 /)  
    endif
    
    call flio_dom_set(phy_size,phy_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
                      'APPLE',phys_domain_id)

!$OMP END MASTER
!$OMP FLUSH(buffer_omp)
      
  end subroutine init_iophy
  
  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
  use dimphy
  use ioipsl
  use write_field
  implicit none
  include 'dimensions90.h'
    
    character*(*), intent(IN) :: name
    integer, intent(in) :: itau0
    real,intent(in) :: zjulian
    real,intent(in) :: dtime
    integer,intent(out) :: nhori
    integer,intent(out) :: nid_day

!$OMP MASTER    
    if (monocpu) then
      call histbeg(name,iim,io_lon, jjphy_nb,io_lat(jjphy_begin:jjphy_end), &
                   1,iim,1,jjphy_nb,itau0, zjulian, dtime, nhori, nid_day)
    else
      call histbeg(name,iim,io_lon, jjphy_nb,io_lat(jjphy_begin:jjphy_end), &
                   1,iim,1,jjphy_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
    endif
!$OMP END MASTER
  
  end subroutine histbeg_phy
  
  subroutine histwrite2d_phy(nid,name,itau,field)
  use dimphy
  use ioipsl
  implicit none
  include 'dimensions90.h'
    
    integer,intent(in) :: nid
    character*(*), intent(IN) :: name
    integer, intent(in) :: itau
    real,dimension(klon),intent(in) :: field

    CALL GatherField_omp(field,buffer_omp,1)    
!$OMP MASTER
    CALL phy2dyn(buffer_omp,tmp_tab2d,1)
    CALL histwrite(nid,name,itau,tmp_tab2d,iim*jjphy_nb,ndex2d)
!$OMP END MASTER    
  end subroutine histwrite2d_phy
  
  subroutine histwrite3d_phy(nid,name,itau,field)
  use dimphy
  use ioipsl
  implicit none
  include 'dimensions90.h'
    
    integer,intent(in) :: nid
    character*(*), intent(IN) :: name
    integer, intent(in) :: itau
    real,dimension(klon,klev),intent(in) :: field
    
    CALL GatherField_omp(field,buffer_omp,klev)
!$OMP MASTER
    CALL phy2dyn(buffer_omp,tmp_tab3d,klev)
    CALL histwrite(nid,name,itau,tmp_tab3d,iim*jjphy_nb*klev,ndex3d)
!$OMP END MASTER    
  end subroutine histwrite3d_phy
  
  
  subroutine phy2dyn(field_phy,field_dyn,nlev)
  use dimphy
  implicit none
  include 'dimensions90.h'
  
    real,dimension(klon_mpi,nlev),intent(in) :: field_phy
    real,dimension(iim,jjphy_nb,nlev),intent(out) :: field_dyn
    integer,intent(in) :: nlev
    
    integer :: next
    integer :: j,l
    
      do l=1,nlev
                
        if (jjphy_begin==jjphy_end) then
          field_dyn(:,1,l)=0.
          field_dyn(iiphy_begin:iiphy_end,1,l)=field_phy(1:klon_mpi,l)
        else
        
         if (jjphy_begin==1) then
            field_dyn(:,1,l)=field_phy(1,l)
            next=2
         else
           field_dyn(:,1,l)=0.
           next=iim-iiphy_begin+2
           field_dyn(iiphy_begin:iim,1,l)=field_phy(1:next-1,l)   
         endif
        
          do j=2,jjphy_nb-1
            field_dyn(:,j,l)=field_phy(next:next+iim-1,l)
            next=next+iim
          enddo
          
          if (jjphy_end==jjm+1) then
             field_dyn(:,jjphy_nb,l)=field_phy(klon_mpi,l)
          else
           field_dyn(:,jjphy_nb,l)=0.
           field_dyn(1:iiphy_end,jjphy_nb,l)=field_phy(next:next+iiphy_end-1,l)   
          endif
          
        endif
     
     enddo
         
    end subroutine phy2dyn          
  
          
end module iophy