source: LMDZ.3.3/branches/rel-LF/libf/bibio/writephys.F90 @ 3722

!
! $Header$
!
  MODULE writephys

!
! Wrapper d'IOIPSL pour l'ecriture des sorties de la physique. Un seul appel 
! par variable devrait (?) suffire pour l'initialisation et l'ecriture
!
! LF, LMD, 07/2001
!
! 2 routines principales:
!   writephy_ini pour l'initialisation des fichiers (appel histbeg, histvert)
!   writephy pour l'ecriture des champs (appel histdef, histwrite)
! dans le futur:
!   writephy_def pour definir des profils de variables
! 
  USE IOIPSL

  IMPLICIT none

  PRIVATE
  PUBLIC :: writephy_ini, writephy, writephy_def, writephy_sync

!
! variables locales 
!
! nombre de fichiers maximum a ouvrir
  integer, parameter :: nb_files_max = 20
! nombre de variables maximum par fichier
  integer, parameter :: nb_var_max = 500
! nombre maximum de "profils" de variables
  integer, parameter :: nb_prof_max = 10
! structure d'infos sur les fichiers
  type fichier
     character*30        :: file_name
     integer             :: nitau
     integer             :: file_id
     integer             :: isize, jsize, lsize, phy_lon
     integer             :: nhori, nvert
     logical             :: define
  end type fichier
  type (fichier), dimension(nb_files_max), save :: hist_files
! structure de profils de variables
  type profils
     real               :: freq_op
     real               :: freq_wri
     character*6        :: var_op
     integer            :: zsize
     integer            :: reg_size
     integer,dimension(:), pointer :: reg_index
  end type profils 
  type (profils), dimension(nb_prof_max, nb_files_max), save :: var_profs

! liste des variables par fichier
  character (len=10), save, dimension(nb_var_max,nb_files_max) :: list_var='undefined'
! nombre de variables par fichier
  integer, save, dimension(nb_files_max) :: nb_var = 0 
! nombre de bits à sauvegarder dans les fichiers
  integer, save :: nbits = 32
!
! Quelques initialisations
!

  CONTAINS

!
!###########################################################################
!
  SUBROUTINE writephy_ini(nid_file, nom_fichier, klon, iim, jjm, llm, &
 &                        rlon, rlat, zlev, &
 &                        date0, dtime)
!
! Initialisation des fichiers histoire de la physique
! Appels a histbeg, histvert
! Remplissage des structures d'informations sur les fichiers
! 
! Entree:
!   nid_file          numero/index du fichier a initialiser
!   nom_fichier       nom du fichier
!   klon              taille des champs physiques
!   iim, jjm, llm     taille en i,j,k      
!   rlon, rlat, zlev  coordonnees en x, y, z
!   date0             date debut
!   dtime             pas de temps elementaire de la physique 
!   
! Declaration des parametres d'entree
  integer :: nid_file
  character*(*) :: nom_fichier
  integer :: iim, jjm, llm, klon
  real, dimension(klon) :: rlon
  real, dimension(klon) :: rlat
  real, dimension(llm) :: zlev
  real                 :: date0, dtime
  integer              :: itau_deb
!
! Variables locales
!
  integer :: i, file_id, nvert, nhori
  real, dimension(iim, jjm) :: temp_lon, temp_lat
  logical, save             :: first_call = .true.
  integer,parameter         :: nulou = 6
!
! Quelques initialisations
!
  if (first_call) then
    hist_files(:)%define = .true.
    var_profs(:,:)%freq_wri = -999
    hist_files(:)%nitau = 1
    first_call= .false.
  endif
!
! Mise des coordonnees sur une grille 2D
!
  call gr_fi_ecrit(1,klon,iim,jjm,rlon,temp_lon)
  do i = 1, iim 
    temp_lon(i,1) = rlon(i+1)
    temp_lon(i,jjm) = rlon(i+1)
  enddo
  call gr_fi_ecrit(1,klon,iim,jjm,rlat,temp_lat)
!
! Initialisation du fichier
!
  call histbeg(nom_fichier, iim, temp_lon(:,1), jjm, temp_lat(1,:), &
     &                 1, iim, 1, jjm, itau_deb, date0, dtime, &
     &                 nhori, file_id)
  call histvert(file_id, "presnivs", "Vertical levels", "mb", &
     &                 llm, zlev, nvert)

!
! Remplissage des infos
!
  hist_files(nid_file)%file_name = nom_fichier
  hist_files(nid_file)%file_id = file_id
  hist_files(nid_file)%isize = iim
  hist_files(nid_file)%jsize = jjm
  hist_files(nid_file)%lsize = llm
  hist_files(nid_file)%phy_lon = klon
  hist_files(nid_file)%nhori = nhori
  hist_files(nid_file)%nvert = nvert

  write(nulou,*)'####################################'
  write(nulou,*)' Definition du fichier no ',nid_file
  write(nulou,*)'    nom du fichier     ',hist_files(nid_file)%file_name
  write(nulou,*)'    identifiant        ',hist_files(nid_file)%file_id
  write(nulou,*)'    taille en i        ',hist_files(nid_file)%isize
  write(nulou,*)'    taille en j        ',hist_files(nid_file)%jsize
  write(nulou,*)'    taille en l        ',hist_files(nid_file)%lsize

!
  END SUBROUTINE writephy_ini
!
!###########################################################################
!
  SUBROUTINE writephy_def(profil_n, nid_file,               &
 &                        var_op, freq_op, freq_wri, zsize, &
 &                        reg_size, reg_index)
!
! Definition de profil type de sortie de variables 
!               (moyenne, instantanee, indexee ...)
!
! Parametres d'entree
!   profil_n      numero du profil-type
!   nid_file      numero de fichier
!   var_op        operation a effectuer sur la variable 
!   freq_op       frequence de l'operation
!   freq_wri      frequence d'ecriture
!   zsize         variable 2D/3D
!   reg_size      taille de la region a sortir
!   reg_index     indices de la region a sortir
!
  integer                         :: profil_n
  integer                         :: nid_file
  character*(*)             :: var_op
  real                            :: freq_op, freq_wri
  integer                         :: zsize
  integer, optional               :: reg_size
  integer, dimension(*), optional :: reg_index
!
! variables locales
!
  character (len = 20) :: modname = 'writephy_def'
  character (len = 80) :: message
  integer              :: dummy_size
  integer              :: error 
  integer,parameter    :: nulou = 6
!
! Differentes verif
!
  if (profil_n > nb_prof_max) then
    message = 'numero de profil de variable > nbre maximal de profil'
    call abort_gcm(modname, message, 1)
  endif
  if (var_profs(profil_n, nid_file)%freq_wri /= -999) then
    message = 'numero de profil deja attribue'
    call abort_gcm(modname, message, 1)
  endif        
!
! Remplissage structure infos
!
  var_profs(profil_n, nid_file)%var_op = var_op
  var_profs(profil_n, nid_file)%freq_op = freq_op
  var_profs(profil_n, nid_file)%freq_wri = freq_wri
  var_profs(profil_n, nid_file)%zsize = zsize
!
! test pour region
!
  if (present (reg_size)) then
    if ( .not. present (reg_index)) then
      message = 'reg_size defini mais pas de region definie'
      call abort_gcm(modname, message, 1)
    endif
    allocate(var_profs(profil_n, nid_file)%reg_index(reg_size), stat = error)
    if (error /= 0) then
      message='Pb allocation reg_index'
      call abort_gcm(modname,message,1)
    endif
    var_profs(profil_n, nid_file)%reg_size = reg_size
    var_profs(profil_n, nid_file)%reg_index = reg_index(1:reg_size)
  else
    dummy_size = 1
    allocate(var_profs(profil_n, nid_file)%reg_index(dummy_size), stat = error)
    if (error /= 0) then
      message='Pb allocation reg_index'
      call abort_gcm(modname,message,1)
    endif
    var_profs(profil_n, nid_file)%reg_size = dummy_size
    var_profs(profil_n, nid_file)%reg_index = 0
  endif

  write(nulou,*)' Definition du profil de variable numero ', profil_n
  write(nulou,*)'                              du fichier ', nid_file
  write(nulou,*)'     operation               ', &
 &                    var_profs(profil_n, nid_file)%var_op
  write(nulou,*)'     frequence d''operation  ', &
 &                    var_profs(profil_n, nid_file)%freq_op
  write(nulou,*)'     frequence d''ecriture   ', &
 &                    var_profs(profil_n, nid_file)%freq_wri
  write(nulou,*)'     2D/3D                   ', &
 &                    var_profs(profil_n, nid_file)%zsize
  write(nulou,*)'     taille de la region     ', &
 &                    var_profs(profil_n, nid_file)%reg_size

  END SUBROUTINE writephy_def
!
!###########################################################################
!
! A faire: rendre var_title et var_units optionels par lecture d'un tableau
!
!
  SUBROUTINE writephy(file, iprof, var_name, data, var_title, var_units)
!
! Definition et ecriture des variables
!
! file             numero du fichier dans lequel ecrire
! iprof            profil de la variable a ecrire
! var_name         nom de la variable a ecrire
! data             les donnees effectives a ecrire  
! var_title        "vrai" nom de la variable, optionel, si non present 
!                  interrogation d'un tableau
! var_units        unite de la variable, optionel, si non present 
!                  interrogation d'un tableau

  integer              :: file, iprof
  character*(*)        :: var_name
  real, dimension(*)   :: data
  character*(*)        :: var_title
  character*(*)        :: var_units
!
! variables locales
!
  integer              :: i, error
  character (len=6)    :: var_op
  real                 :: freq_op, freq_wri
  integer              :: file_id, isize, jsize, lsize, phy_lon, zsize
  integer              :: nhori, nvert, klon
  integer              :: itau
  real, dimension(:,:,:), allocatable :: temp_data
  character (len = 20) :: modname = 'writephy'
  character (len = 80) :: message
!
! Test: toujours en mode definition des variables?
!
  if (var_name == list_var(1, file)) then
    hist_files(file)%nitau = hist_files(file)%nitau + 1
  endif
  if (hist_files(file)%define) then
    if (var_name == list_var(1, file)) then
!     on a fait le tour des variables
      hist_files(file)%define = .false.
      call histend(hist_files(file)%file_id)
    else
!
! pour que l'appel a histdef soit plus lisible, on range tout dans des tampons
!
      file_id = hist_files(file)%file_id
      isize = hist_files(file)%isize
      jsize = hist_files(file)%jsize    
      nhori = hist_files(file)%nhori
      klon = hist_files(file)%phy_lon
      var_op = var_profs(iprof, file)%var_op
      freq_op = var_profs(iprof, file)%freq_op
      freq_wri = var_profs(iprof, file)%freq_wri
      if (var_profs(iprof, file)%zsize == 0) then
        lsize = 1
        nvert = -99
      else
        lsize = hist_files(file)%lsize
        nvert = hist_files(file)%nvert
      endif
!      if (var_name == 'phis') then
!        write(*,*)'Define: ',var_name
!        write(*,*)file_id, var_name, var_title, var_units,  &
! &                isize, jsize, nhori, lsize, 1, lsize, nvert, nbits,  &
! &                var_op, freq_op, freq_wri
!      endif
      call histdef(file_id, var_name, var_title, var_units,  &
 &                isize, jsize, nhori, lsize, 1, lsize, nvert, nbits,  &
 &                var_op, freq_op, freq_wri)
      nb_var(file) = nb_var(file) + 1
      list_var(nb_var(file), file) = var_name
    endif
  endif
!
! On ecrit la variable
!
! Preparation
!
  file_id = hist_files(file)%file_id
  isize = hist_files(file)%isize
  jsize = hist_files(file)%jsize    
  nhori = hist_files(file)%nhori
  var_op = var_profs(iprof, file)%var_op
  freq_op = var_profs(iprof, file)%freq_op
  freq_wri = var_profs(iprof, file)%freq_wri
  itau = hist_files(file)%nitau

  if (var_profs(iprof, file)%zsize == 0) then
    lsize = 1
  else
    lsize = hist_files(file)%lsize
  endif
  allocate(temp_data(isize,jsize,lsize), stat = error)
  if (error /= 0) then
    message='Pb allocation temp_data'
    call abort_gcm(modname, message, 1)
  endif
!
! Ecriture
!
  call gr_fi_ecrit(lsize, klon, isize, jsize, data, temp_data)
  if (var_name == 'tsol') then
    write(*,*)'writephys itau = ', file_id, var_name, itau
!    write(*,*)file_id, var_name,itau,temp_data, &
! &               var_profs(iprof, file)%reg_size, &
! &               var_profs(iprof, file)%reg_index
  endif
  call histwrite(file_id, var_name,itau,temp_data, &
 &               var_profs(iprof, file)%reg_size, &
 &               var_profs(iprof, file)%reg_index)

  deallocate(temp_data)
 
  return
!
  END SUBROUTINE writephy 
!
!###########################################################################
!
  SUBROUTINE writephy_sync(nid_file)
!
! Flush des donnees dans le fichier et eventuellement fermeture du 
! mode 'define'
!
! Entree:
!   nid_file    numero du fichier a traiter
!
  integer     :: nid_file
!
  if (hist_files(nid_file)%define) then
    call histend(hist_files(nid_file)%file_id)
    hist_files(nid_file)%define = .false.
  endif

  call histsync(hist_files(nid_file)%file_id)
  
return

  END SUBROUTINE writephy_sync 
!
!###########################################################################
!
  END MODULE writephys