/[lmdze]/trunk/phylmd/Interface_surf/conf_interface.f
ViewVC logotype

Diff of /trunk/phylmd/Interface_surf/conf_interface.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3 by guez, Wed Feb 27 13:16:39 2008 UTC revision 12 by guez, Mon Jul 21 16:05:07 2008 UTC
# Line 104  CONTAINS Line 104  CONTAINS
104      !   p1lay        pression 1er niveau (milieu de couche)      !   p1lay        pression 1er niveau (milieu de couche)
105      !   ps           pression au sol      !   ps           pression au sol
106      !   radsol       rayonnement net aus sol (LW + SW)      !   radsol       rayonnement net aus sol (LW + SW)
107      !   ocean        type d'ocean utilise (force, slab, couple)      !   ocean        type d'ocean utilise ("force" ou "slab" mais pas "couple")
108      !   fder         derivee des flux (pour le couplage)      !   fder         derivee des flux (pour le couplage)
109      !   taux, tauy   tension de vents      !   taux, tauy   tension de vents
110      !   windsp       module du vent a 10m      !   windsp       module du vent a 10m
# Line 165  CONTAINS Line 165  CONTAINS
165      real, dimension(klon), intent(IN) :: zmasq      real, dimension(klon), intent(IN) :: zmasq
166      real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro      real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro
167      real, dimension(klon), intent(IN) :: windsp      real, dimension(klon), intent(IN) :: windsp
168      character (len = 6)  :: ocean      character(len=*), intent(IN):: ocean
169      integer              :: npas, nexca ! nombre et pas de temps couplage      integer              :: npas, nexca ! nombre et pas de temps couplage
170      real, dimension(klon), intent(INOUT) :: evap, snow, qsurf      real, dimension(klon), intent(INOUT) :: evap, snow, qsurf
171      !! PB ajout pour soil      !! PB ajout pour soil
172      logical          :: soil_model      logical, intent(in):: soil_model
173      integer          :: nsoilmx      integer          :: nsoilmx
174      REAL, DIMENSION(klon, nsoilmx) :: tsoil      REAL, DIMENSION(klon, nsoilmx) :: tsoil
175      REAL, dimension(klon), intent(INOUT) :: qsol      REAL, dimension(klon), intent(INOUT) :: qsol
# Line 236  CONTAINS Line 236  CONTAINS
236            abort_message='voir ci-dessus'            abort_message='voir ci-dessus'
237            call abort_gcm(modname,abort_message,1)            call abort_gcm(modname,abort_message,1)
238         endif         endif
239         if (ocean /= 'slab' .and. ocean /= 'force' .and. ocean /= 'couple') then         if (ocean /= 'slab' .and. ocean /= 'force') then
240            write(*,*)' *** Warning ***'            write(*,*)' *** Warning ***'
241            write(*,*)'Option couplage pour l''ocean = ', ocean            write(*,*)'Option couplage pour l''ocean = ', ocean
242            abort_message='option pour l''ocean non valable'            abort_message='option pour l''ocean non valable'
# Line 440  CONTAINS Line 440  CONTAINS
440         pctsrf_new(:,nisurf) = pctsrf(:,nisurf)         pctsrf_new(:,nisurf) = pctsrf(:,nisurf)
441    
442      else if (nisurf == is_oce) then      else if (nisurf == is_oce) then
   
        if (check) write(*,*)'ocean, nisurf = ',nisurf  
   
        !  
443         ! Surface "ocean" appel a l'interface avec l'ocean         ! Surface "ocean" appel a l'interface avec l'ocean
444         !         !
445         if (ocean == 'couple') then         if (ocean == 'slab  ') then
           if (nexca == 0) then  
              abort_message='nexca = 0 dans interfoce_cpl'  
              call abort_gcm(modname,abort_message,1)  
           endif  
   
           cumul = .false.  
   
           iloc = maxloc(fder(1:klon))  
           if (check) then  
              if (fder(iloc(1))> 0.) then  
                 WRITE(*,*)'**** Debug fder ****'  
                 WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))  
              endif  
           endif  
 !!$  
 !!$      where(fder.gt.0.)  
 !!$        fder = 0.  
 !!$      endwhere  
   
           call interfoce_cpl(itime, dtime, cumul, &  
                & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &  
                & ocean, npas, nexca, debut, lafin, &  
                & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &  
                & fluxlat, fluxsens, fder, albedo, taux, tauy, &  
                & windsp, &  
                & zmasq, &  
                & tsurf_new, alb_new, &  
                & pctsrf_new)  
   
           !IM: "slab" ocean  
        else if (ocean == 'slab  ') then  
446            tsurf_new = tsurf            tsurf_new = tsurf
447            pctsrf_new = tmp_pctsrf_slab            pctsrf_new = tmp_pctsrf_slab
448            !            !
# Line 530  CONTAINS Line 495  CONTAINS
495         ! 2eme appel a interfoce pour le cumul des champs (en particulier         ! 2eme appel a interfoce pour le cumul des champs (en particulier
496         ! fluxsens et fluxlat calcules dans calcul_fluxs)         ! fluxsens et fluxlat calcules dans calcul_fluxs)
497         !         !
498         if (ocean == 'couple') then         if (ocean == 'slab  ') then
   
           cumul = .true.  
   
           call interfoce_cpl(itime, dtime, cumul, &  
                & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &  
                & ocean, npas, nexca, debut, lafin, &  
                & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &  
                & fluxlat, fluxsens, fder, albedo, taux, tauy, &  
                & windsp, &  
                & zmasq, &  
                & tsurf_new, alb_new, &  
                & pctsrf_new)  
   
           !IM: "slab" ocean  
        else if (ocean == 'slab  ') then  
499            !            !
500            seaice=tmp_seaice            seaice=tmp_seaice
501            cumul = .true.            cumul = .true.
# Line 585  CONTAINS Line 535  CONTAINS
535         ! Surface "glace de mer" appel a l'interface avec l'ocean         ! Surface "glace de mer" appel a l'interface avec l'ocean
536         !         !
537         !         !
538         if (ocean == 'couple') then         if (ocean == 'slab  ') then
   
           cumul =.false.  
   
           iloc = maxloc(fder(1:klon))  
           if (check.and.fder(iloc(1))> 0.) then  
              WRITE(*,*)'**** Debug fder ****'  
              WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))  
           endif  
 !!$  
 !!$      where(fder.gt.0.)  
 !!$        fder = 0.  
 !!$      endwhere  
   
           call interfoce_cpl(itime, dtime, cumul, &  
                & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &  
                & ocean, npas, nexca, debut, lafin, &  
                & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &  
                & fluxlat, fluxsens, fder, albedo, taux, tauy, &  
                & windsp, &  
                & zmasq, &  
                & tsurf_new, alb_new, &  
                & pctsrf_new)  
   
           tsurf_temp = tsurf_new  
           cal = 0.  
           dif_grnd = 0.  
           beta = 1.0  
   
           !IM: "slab" ocean  
        else if (ocean == 'slab  ') then  
539            pctsrf_new=tmp_pctsrf_slab            pctsrf_new=tmp_pctsrf_slab
540            !            !
541            DO ii = 1, knon            DO ii = 1, knon
# Line 708  CONTAINS Line 628  CONTAINS
628            tmp_radsol(knindex(i))=radsol(i)            tmp_radsol(knindex(i))=radsol(i)
629         ENDDO         ENDDO
630    
631         IF (ocean /= 'couple') THEN         CALL fonte_neige( klon, knon, nisurf, dtime, &
632            CALL fonte_neige( klon, knon, nisurf, dtime, &              &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
633                 &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &              &   precip_rain, precip_snow, snow, qsol,  &
634                 &   precip_rain, precip_snow, snow, qsol,  &              &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
635                 &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &              &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
636                 &   petAcoef, peqAcoef, petBcoef, peqBcoef, &              &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
637                 &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &              &   fqcalving,ffonte, run_off_lic_0)
                &   fqcalving,ffonte, run_off_lic_0)  
638    
639            !     calcul albedo         !     calcul albedo
640    
641            CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))           CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
642            WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.         WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
643            zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))         zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
644            alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + &         alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + &
645                 &                    0.6 * (1.0-zfra(1:knon))              0.6 * (1.0-zfra(1:knon))
           !!      alb_new(1 : knon) = 0.6  
        ENDIF  
646    
647         fder_prev = fder             fder_prev = fder    
648         fder = fder_prev + dflux_s + dflux_l         fder = fder_prev + dflux_s + dflux_l
# Line 737  CONTAINS Line 654  CONTAINS
654            WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), &            WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), &
655                 &                        dflux_s(iloc(1)), dflux_l(iloc(1))                 &                        dflux_s(iloc(1)), dflux_l(iloc(1))
656         endif         endif
 !!$      where(fder.gt.0.)  
 !!$        fder = 0.  
 !!$      endwhere  
657    
658         !         !
659         ! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean         ! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
660         !         !
        if (ocean == 'couple') then  
   
           cumul =.true.  
   
           call interfoce_cpl(itime, dtime, cumul, &  
                & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &  
                & ocean, npas, nexca, debut, lafin, &  
                & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &  
                & fluxlat, fluxsens, fder, albedo, taux, tauy, &  
                & windsp, &  
                & zmasq, &  
                & tsurf_new, alb_new, &  
                & pctsrf_new)  
        endif  
   
661         z0_new = 0.002         z0_new = 0.002
662         z0_new = SQRT(z0_new**2+rugoro**2)         z0_new = SQRT(z0_new**2+rugoro**2)
663         alblw(1:knon) = alb_new(1:knon)         alblw(1:knon) = alb_new(1:knon)
# Line 845  CONTAINS Line 744  CONTAINS
744    
745    !************************    !************************
746    
   SUBROUTINE interfoce_cpl(itime, dtime, cumul, &  
        & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &  
        & ocean, npas, nexca, debut, lafin, &  
        & swdown, lwdown, precip_rain, precip_snow, evap, tsurf, &  
        & fluxlat, fluxsens, fder, albsol, taux, tauy, &  
        & windsp, &  
        & zmasq, &  
        & tsurf_new, alb_new, &  
        & pctsrf_new)  
   
     ! Cette routine sert d'interface entre le modele atmospherique et un  
     ! coupleur avec un modele d'ocean 'complet' derriere  
     !  
     ! Le modele de glace qu'il est prevu d'utiliser etant couple directement a  
     ! l'ocean presentement, on va passer deux fois dans cette routine par pas de  
     ! temps physique, une fois avec les points oceans et l'autre avec les points  
     ! glace. A chaque pas de temps de couplage, la lecture des champs provenant  
     ! du coupleur se fera "dans" l'ocean et l'ecriture des champs a envoyer  
     ! au coupleur "dans" la glace. Il faut donc des tableaux de travail "tampons"  
     ! dimensionnes sur toute la grille qui remplissent les champs sur les  
     ! domaines ocean/glace quand il le faut. Il est aussi necessaire que l'index  
     ! ocean soit traiter avant l'index glace (sinon tout intervertir)  
     !  
     !  
     ! L. Fairhead 02/2000  
     !  
     ! input:  
     !   itime        numero du pas de temps  
     !   iim, jjm     nbres de pts de grille  
     !   dtime        pas de temps de la physique  
     !   klon         nombre total de points de grille  
     !   nisurf       index de la surface a traiter (1 = sol continental)  
     !   pctsrf       tableau des fractions de surface de chaque maille  
     !   knon         nombre de points de la surface a traiter  
     !   knindex      index des points de la surface a traiter  
     !   rlon         longitudes  
     !   rlat         latitudes  
     !   debut        logical: 1er appel a la physique  
     !   lafin        logical: dernier appel a la physique  
     !   ocean        type d'ocean  
     !   nexca        frequence de couplage  
     !   swdown       flux solaire entrant a la surface  
     !   lwdown       flux IR net a la surface  
     !   precip_rain  precipitation liquide  
     !   precip_snow  precipitation solide  
     !   evap         evaporation  
     !   tsurf        temperature de surface  
     !   fder         derivee dF/dT  
     !   albsol       albedo du sol (coherent avec swdown)  
     !   taux         tension de vent en x  
     !   tauy         tension de vent en y  
     !    windsp       module du vent a 10m  
     !   nexca        frequence de couplage  
     !   zmasq        masque terre/ocean  
     !  
     !  
     ! output:  
     !   tsurf_new    temperature au sol  
     !   alb_new      albedo  
     !   pctsrf_new   nouvelle repartition des surfaces  
     !   alb_ice      albedo de la glace  
     !  
     use temps  
     use iniprint  
     use abort_gcm_m, only: abort_gcm  
     use gath_cpl, only: gath2cpl, cpl2gath  
     use ioipsl  
     use indicesol  
     use YOMCST  
   
     ! Parametres d'entree  
     integer, intent(IN) :: itime  
     integer, intent(IN) :: iim, jjm  
     real, intent(IN) :: dtime  
     integer, intent(IN) :: klon  
     integer, intent(IN) :: nisurf  
     integer, intent(IN) :: knon  
     real, dimension(klon,nbsrf), intent(IN) :: pctsrf  
     integer, dimension(klon), intent(in) :: knindex  
     logical, intent(IN) :: debut, lafin  
     real, dimension(klon), intent(IN) :: rlon, rlat  
     character (len = 6)  :: ocean  
     real, dimension(klon), intent(IN) :: lwdown, swdown  
     real, dimension(klon), intent(IN) :: precip_rain, precip_snow  
     real, dimension(klon), intent(IN) :: tsurf, fder, albsol, taux, tauy  
     real, dimension(klon), intent(IN) :: windsp  
     INTEGER              :: nexca, npas  
     real, dimension(klon), intent(IN) :: zmasq  
     real, dimension(klon), intent(IN) :: fluxlat, fluxsens  
     logical, intent(IN)               :: cumul  
     real, dimension(klon), intent(INOUT) :: evap  
   
     ! Parametres de sortie  
     real, dimension(klon), intent(OUT):: tsurf_new, alb_new  
     real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new  
   
     ! Variables locales  
     integer                    :: j, error, sum_error, ig, cpl_index,i  
     INTEGER :: nsrf  
     character (len = 20) :: modname = 'interfoce_cpl'  
     character (len = 80) :: abort_message  
     logical,save              :: check = .FALSE.  
     ! variables pour moyenner les variables de couplage  
     real, allocatable, dimension(:,:),save :: cpl_sols, cpl_nsol, cpl_rain  
     real, allocatable, dimension(:,:),save :: cpl_snow, cpl_evap, cpl_tsol  
     real, allocatable, dimension(:,:),save :: cpl_fder, cpl_albe, cpl_taux  
     real, allocatable, dimension(:,:),save :: cpl_windsp  
     real, allocatable, dimension(:,:),save :: cpl_tauy  
     REAL, ALLOCATABLE, DIMENSION(:,:),SAVE :: cpl_rriv, cpl_rcoa, cpl_rlic  
 !!$  
     ! variables tampons avant le passage au coupleur  
     real, allocatable, dimension(:,:,:),save :: tmp_sols, tmp_nsol, tmp_rain  
     real, allocatable, dimension(:,:,:),save :: tmp_snow, tmp_evap, tmp_tsol  
     real, allocatable, dimension(:,:,:),save :: tmp_fder, tmp_albe, tmp_taux  
     real, allocatable, dimension(:,:,:),save :: tmp_windsp  
     REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: tmp_tauy  
     ! variables a passer au coupleur  
     real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice  
     real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice  
     REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv  
     REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy  
     REAL, DIMENSION(iim, jjm+1) :: wri_windsp  
     REAL, DIMENSION(iim, jjm+1) :: wri_calv  
     REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz  
     REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat  
     ! variables relues par le coupleur  
     ! read_sic = fraction de glace  
     ! read_sit = temperature de glace  
     real, allocatable, dimension(:,:),save :: read_sst, read_sic, read_sit  
     real, allocatable, dimension(:,:),save :: read_alb_sic  
     ! variable tampon  
     real, dimension(klon)       :: tamp_sic  
     ! sauvegarde des fractions de surface d'un pas de temps a l'autre apres  
     ! l'avoir lu  
     real, allocatable,dimension(:,:),save :: pctsrf_sav  
     real, dimension(iim, jjm+1, 2) :: tamp_srf  
     integer, allocatable, dimension(:), save :: tamp_ind  
     real, allocatable, dimension(:,:),save :: tamp_zmasq  
     real, dimension(iim, jjm+1) :: deno  
     integer                     :: idtime  
     integer, allocatable,dimension(:),save :: unity  
     !  
     logical, save    :: first_appel = .true.  
     logical,save          :: print  
     !maf  
     ! variables pour avoir une sortie IOIPSL des champs echanges  
     CHARACTER(len=80),SAVE :: clintocplnam, clfromcplnam  
     INTEGER, SAVE :: jf,nhoridct,nidct  
     INTEGER, SAVE :: nhoridcs,nidcs  
     INTEGER :: ndexct(iim*(jjm+1)),ndexcs(iim*(jjm+1))  
     REAL :: zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian  
     INTEGER,save :: idayref  
     !med  integer :: itau_w  
     integer,save :: itau_w  
     integer :: nb_interf_cpl  
     include "param_cou.h"  
     include "inc_cpl.h"  
     !  
     ! Initialisation  
     !  
     if (check) write(*,*)'Entree ',modname,'nisurf = ',nisurf  
   
     if (first_appel) then  
        error = 0  
        allocate(unity(klon), stat = error)  
        if ( error  /=0) then  
           abort_message='Pb allocation variable unity'  
           call abort_gcm(modname,abort_message,1)  
        endif  
        allocate(pctsrf_sav(klon,nbsrf), stat = error)  
        if ( error  /=0) then  
           abort_message='Pb allocation variable pctsrf_sav'  
           call abort_gcm(modname,abort_message,1)  
        endif  
        pctsrf_sav = 0.  
   
        do ig = 1, klon  
           unity(ig) = ig  
        enddo  
        sum_error = 0  
        allocate(cpl_sols(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_nsol(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_rain(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_snow(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_evap(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_tsol(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_fder(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_albe(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_taux(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_windsp(klon,2), stat = error); sum_error = sum_error + error  
        allocate(cpl_tauy(klon,2), stat = error); sum_error = sum_error + error  
        ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error  
        ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error  
        ALLOCATE(cpl_rlic(iim,jjm+1), stat=error); sum_error = sum_error + error  
        !!  
        allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error  
        allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error  
        allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error  
        allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error  
   
        if (sum_error /= 0) then  
           abort_message='Pb allocation variables couplees'  
           call abort_gcm(modname,abort_message,1)  
        endif  
        cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.  
        cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.  
        cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0.  
        cpl_windsp = 0.  
   
        sum_error = 0  
        allocate(tamp_ind(klon), stat = error); sum_error = sum_error + error  
        allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error      
        do ig = 1, klon  
           tamp_ind(ig) = ig  
        enddo  
        call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jjm, tamp_ind)  
        !  
        ! initialisation couplage  
        !  
        idtime = int(dtime)  
        !  
        ! initialisation sorties netcdf  
        !  
        idayref = day_ini  
        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)  
        CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)  
        DO i = 1, iim  
           zx_lon(i,1) = rlon(i+1)  
           zx_lon(i,jjm+1) = rlon(i+1)  
        ENDDO  
        CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)  
        clintocplnam="cpl_atm_tauflx"  
        CALL histbeg_totreg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &  
             & itau_phy,zjulian,dtime,nhoridct,nidct)  
        ! no vertical axis  
        CALL histdef(nidct, 'tauxe','tauxe', &  
             & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        CALL histdef(nidct, 'tauyn','tauyn', &  
             & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        CALL histdef(nidct, 'tmp_lon','tmp_lon', &  
             & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        CALL histdef(nidct, 'tmp_lat','tmp_lat', &  
             & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        DO jf=1,jpflda2o1 + jpflda2o2  
           CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &  
                & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        END DO  
        CALL histend(nidct)  
        CALL histsync(nidct)  
   
        clfromcplnam="cpl_atm_sst"  
        CALL histbeg_totreg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &  
             & 0,zjulian,dtime,nhoridcs,nidcs)  
        ! no vertical axis  
        DO jf=1,jpfldo2a  
           CALL histdef(nidcs, cl_read(jf),cl_read(jf), &  
                & "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)  
        END DO  
        CALL histend(nidcs)  
        CALL histsync(nidcs)  
   
        ! pour simuler la fonte des glaciers antarctiques  
        !  
        surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1))  
        ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error)  
        if (error /= 0) then  
           abort_message='Pb allocation variable coeff_iceberg'  
           call abort_gcm(modname,abort_message,1)  
        endif  
        open (12,file='flux_iceberg',form='formatted',status='old')  
        read (12,*) coeff_iceberg  
        close (12)  
        num_antarctic = max(1, count(coeff_iceberg > 0))  
   
        first_appel = .false.  
     endif ! fin if (first_appel)  
   
     ! Initialisations  
   
     ! calcul des fluxs a passer  
     nb_interf_cpl = nb_interf_cpl + 1    
     if (check) write(lunout,*)'passage dans interface_surf.F90 :  ',nb_interf_cpl  
     cpl_index = 1  
     if (nisurf == is_sic) cpl_index = 2  
     if (cumul) then  
        if (check) write(lunout,*)'passage dans cumul '  
        if (check) write(lunout,*)'valeur de cpl_index ', cpl_index  
        ! -- LOOP    
        if (check) write(*,*) modname, 'cumul des champs'  
        do ig = 1, knon  
           cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) &  
                &                          + swdown(ig)      / FLOAT(nexca)  
           cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) &  
                &                          + (lwdown(ig) + fluxlat(ig) +fluxsens(ig))&  
                &                                / FLOAT(nexca)  
           cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) &  
                &                          + precip_rain(ig) / FLOAT(nexca)  
           cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) &  
                &                          + precip_snow(ig) / FLOAT(nexca)  
           cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) &  
                &                          + evap(ig)        / FLOAT(nexca)  
           cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) &  
                &                          + tsurf(ig)       / FLOAT(nexca)  
           cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) &  
                &                          + fder(ig)        / FLOAT(nexca)  
           cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) &  
                &                          + albsol(ig)      / FLOAT(nexca)  
           cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) &  
                &                          + taux(ig)        / FLOAT(nexca)  
           cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) &  
                &                          + tauy(ig)        / FLOAT(nexca)  
           IF (cpl_index .EQ. 1) THEN  
              cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) &  
                   &                          + windsp(ig)      / FLOAT(nexca)  
           ENDIF  
        enddo  
        IF (cpl_index .EQ. 1) THEN  
           cpl_rriv(:,:) = cpl_rriv(:,:) + tmp_rriv(:,:) / FLOAT(nexca)  
           cpl_rcoa(:,:) = cpl_rcoa(:,:) + tmp_rcoa(:,:) / FLOAT(nexca)  
           cpl_rlic(:,:) = cpl_rlic(:,:) + tmp_rlic(:,:) / FLOAT(nexca)  
        ENDIF  
     endif  
   
     if (mod(itime, nexca) == 1) then  
        !  
        ! Demande des champs au coupleur  
        !  
        ! Si le domaine considere est l'ocean, on lit les champs venant du coupleur  
        !  
        if (nisurf == is_oce .and. .not. cumul) then  
           if (check) write(*,*)'rentree fromcpl, itime-1 = ',itime-1  
           !  
           ! sorties NETCDF des champs recus  
           !  
           ndexcs(:)=0  
           itau_w = itau_phy + itime  
           CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs)  
           CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs)  
           CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs)  
           CALL histwrite(nidcs,cl_read(4),itau_w,read_sit,iim*(jjm+1),ndexcs)  
           CALL histsync(nidcs)  
           ! pas utile      IF (npas-itime.LT.nexca )CALL histclo(nidcs)  
   
           do j = 1, jjm + 1  
              do ig = 1, iim  
                 if (abs(1. - read_sic(ig,j)) < 0.00001) then  
                    read_sst(ig,j) = RTT - 1.8  
                    read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)  
                    read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)  
                 else if (abs(read_sic(ig,j)) < 0.00001) then  
                    read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))  
                    read_sit(ig,j) = read_sst(ig,j)  
                    read_alb_sic(ig,j) =  0.6  
                 else  
                    read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))  
                    read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)  
                    read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)  
                 endif  
              enddo  
           enddo  
           !  
           ! transformer read_sic en pctsrf_sav  
           !  
           call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jjm, unity)  
           do ig = 1, klon  
              IF (pctsrf(ig,is_oce) > epsfra .OR.            &  
                   &             pctsrf(ig,is_sic) > epsfra) THEN  
                 pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &  
                      &                               * tamp_sic(ig)  
                 pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &  
                      &                        - pctsrf_sav(ig,is_sic)  
              endif  
           enddo  
           !  
           ! Pour rattraper des erreurs d'arrondis  
           !  
           where (abs(pctsrf_sav(:,is_sic)) .le. 2.*epsilon(pctsrf_sav(1,is_sic)))  
              pctsrf_sav(:,is_sic) = 0.  
              pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)  
           endwhere  
           where (abs(pctsrf_sav(:,is_oce)) .le. 2.*epsilon(pctsrf_sav(1,is_oce)))  
              pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)  
              pctsrf_sav(:,is_oce) = 0.  
           endwhere  
           if (minval(pctsrf_sav(:,is_oce)) < 0.) then  
              write(*,*)'Pb fraction ocean inferieure a 0'  
              write(*,*)'au point ',minloc(pctsrf_sav(:,is_oce))  
              write(*,*)'valeur = ',minval(pctsrf_sav(:,is_oce))  
              abort_message = 'voir ci-dessus'  
              call abort_gcm(modname,abort_message,1)  
           endif  
           if (minval(pctsrf_sav(:,is_sic)) < 0.) then  
              write(*,*)'Pb fraction glace inferieure a 0'  
              write(*,*)'au point ',minloc(pctsrf_sav(:,is_sic))  
              write(*,*)'valeur = ',minval(pctsrf_sav(:,is_sic))  
              abort_message = 'voir ci-dessus'  
              call abort_gcm(modname,abort_message,1)  
           endif  
        endif  
     endif                         ! fin mod(itime, nexca) == 1  
   
     if (mod(itime, nexca) == 0) then  
        !  
        ! allocation memoire  
        if (nisurf == is_oce .and. (.not. cumul) ) then  
           sum_error = 0  
           allocate(tmp_sols(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_nsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_rain(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_snow(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_evap(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_tsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_fder(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_albe(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_taux(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_tauy(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           allocate(tmp_windsp(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
 !!$      allocate(tmp_rriv(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
 !!$      allocate(tmp_rcoa(iim,jjm+1,2), stat=error); sum_error = sum_error + error  
           if (sum_error /= 0) then  
              abort_message='Pb allocation variables couplees pour l''ecriture'  
              call abort_gcm(modname,abort_message,1)  
           endif  
        endif  
   
        !  
        ! Mise sur la bonne grille des champs a passer au coupleur  
        !  
        cpl_index = 1  
        if (nisurf == is_sic) cpl_index = 2  
        call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
        call gath2cpl(cpl_windsp(1,cpl_index), tmp_windsp(1,1,cpl_index), klon, knon,iim,jjm,             knindex)  
        call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)  
   
        !  
        ! Si le domaine considere est la banquise, on envoie les champs au coupleur  
        !  
        if (nisurf == is_sic .and. cumul) then  
           wri_rain = 0.; wri_snow = 0.; wri_rcoa = 0.; wri_rriv = 0.  
           wri_taux = 0.; wri_tauy = 0.  
           wri_windsp = 0.  
           ! -- LOOP        
           call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jjm, tamp_ind)  
           call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jjm, tamp_ind)  
   
           wri_sol_ice = tmp_sols(:,:,2)  
           wri_sol_sea = tmp_sols(:,:,1)  
           wri_nsol_ice = tmp_nsol(:,:,2)  
           wri_nsol_sea = tmp_nsol(:,:,1)  
           wri_fder_ice = tmp_fder(:,:,2)  
           wri_evap_ice = tmp_evap(:,:,2)  
           wri_evap_sea = tmp_evap(:,:,1)  
           wri_windsp = tmp_windsp(:,:,1)  
   
 !!$PB  
           wri_rriv = cpl_rriv(:,:)  
           wri_rcoa = cpl_rcoa(:,:)  
           DO j = 1, jjm + 1  
              wri_calv(:,j) = sum(cpl_rlic(:,j)) / iim  
           enddo  
   
           where (tamp_zmasq /= 1.)  
              deno =  tamp_srf(:,:,1) + tamp_srf(:,:,2)  
              wri_rain = tmp_rain(:,:,1) * tamp_srf(:,:,1) / deno +    &  
                   &            tmp_rain(:,:,2) * tamp_srf(:,:,2) / deno  
              wri_snow = tmp_snow(:,:,1) * tamp_srf(:,:,1) / deno +    &  
                   &            tmp_snow(:,:,2) * tamp_srf(:,:,2) / deno  
              wri_taux = tmp_taux(:,:,1) * tamp_srf(:,:,1) / deno +    &  
                   &            tmp_taux(:,:,2) * tamp_srf(:,:,2) / deno  
              wri_tauy = tmp_tauy(:,:,1) * tamp_srf(:,:,1) / deno +    &  
                   &            tmp_tauy(:,:,2) * tamp_srf(:,:,2) / deno  
           endwhere  
           !  
           ! pour simuler la fonte des glaciers antarctiques  
           !  
           !$$$        wri_rain = wri_rain      &  
           !$$$      &     + coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)  
           !      wri_calv = coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)  
           !  
           ! on passe les coordonnées de la grille  
           !  
   
           CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon)  
           CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat)  
   
           DO i = 1, iim  
              tmp_lon(i,1) = rlon(i+1)  
              tmp_lon(i,jjm + 1) = rlon(i+1)  
           ENDDO  
           !  
           ! sortie netcdf des champs pour le changement de repere  
           !  
           ndexct(:)=0  
           CALL histwrite(nidct,'tauxe',itau_w,wri_taux,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,'tauyn',itau_w,wri_tauy,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)  
   
           !  
           ! calcul 3 coordonnées du vent  
           !  
           CALL atm2geo (iim , jjm + 1, wri_taux, wri_tauy, tmp_lon, tmp_lat, &  
                & wri_tauxx, wri_tauyy, wri_tauzz )  
           !  
           ! sortie netcdf des champs apres changement de repere et juste avant  
           ! envoi au coupleur  
           !  
           CALL histwrite(nidct,cl_writ(8),itau_w,wri_sol_ice,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(9),itau_w,wri_sol_sea,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(10),itau_w,wri_nsol_ice,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(11),itau_w,wri_nsol_sea,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(12),itau_w,wri_fder_ice,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(13),itau_w,wri_evap_ice,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(14),itau_w,wri_evap_sea,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(15),itau_w,wri_rain,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(16),itau_w,wri_snow,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(17),itau_w,wri_rcoa,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(18),itau_w,wri_rriv,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(19),itau_w,wri_calv,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(1),itau_w,wri_tauxx,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(2),itau_w,wri_tauyy,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(3),itau_w,wri_tauzz,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(4),itau_w,wri_tauxx,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(5),itau_w,wri_tauyy,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(6),itau_w,wri_tauzz,iim*(jjm+1),ndexct)  
           CALL histwrite(nidct,cl_writ(7),itau_w,wri_windsp,iim*(jjm+1),ndexct)  
           CALL histsync(nidct)  
           ! pas utile      IF (lafin) CALL histclo(nidct)  
           !  
           cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.  
           cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.  
           cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0.  
           cpl_windsp = 0.  
           !  
           ! deallocation memoire variables temporaires  
           !  
           sum_error = 0  
           deallocate(tmp_sols, stat=error); sum_error = sum_error + error  
           deallocate(tmp_nsol, stat=error); sum_error = sum_error + error  
           deallocate(tmp_rain, stat=error); sum_error = sum_error + error  
           deallocate(tmp_snow, stat=error); sum_error = sum_error + error  
           deallocate(tmp_evap, stat=error); sum_error = sum_error + error  
           deallocate(tmp_fder, stat=error); sum_error = sum_error + error  
           deallocate(tmp_tsol, stat=error); sum_error = sum_error + error  
           deallocate(tmp_albe, stat=error); sum_error = sum_error + error  
           deallocate(tmp_taux, stat=error); sum_error = sum_error + error  
           deallocate(tmp_tauy, stat=error); sum_error = sum_error + error  
           deallocate(tmp_windsp, stat=error); sum_error = sum_error + error  
           if (sum_error /= 0) then  
              abort_message='Pb deallocation variables couplees'  
              call abort_gcm(modname,abort_message,1)  
           endif  
   
        endif  
   
     endif            ! fin (mod(itime, nexca) == 0)  
     !  
     ! on range les variables lues/sauvegardees dans les bonnes variables de sortie  
     !  
     if (nisurf == is_oce) then  
        call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jjm, knindex)  
     else if (nisurf == is_sic) then  
        call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jjm, knindex)  
        call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jjm, knindex)  
     endif  
     pctsrf_new(:,nisurf) = pctsrf_sav(:,nisurf)  
   
     !  if (lafin) call quitcpl  
   
   END SUBROUTINE interfoce_cpl  
   
   !************************  
   
747    SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &    SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &
748         & radsol, fluxo, fluxg, pctsrf, &         & radsol, fluxo, fluxg, pctsrf, &
749         & tslab, seaice, pctsrf_slab)         & tslab, seaice, pctsrf_slab)
Legend:
Removed from v.3  
changed lines
  Added in v.12
  ViewVC Help
Powered by ViewVC 1.1.21