--- trunk/libf/dyn3d/guide.f90	2010/12/02 17:11:04	36
+++ trunk/libf/dyn3d/guide.f90	2010/12/21 15:45:48	37
@@ -3,6 +3,8 @@
   ! From dyn3d/guide.F, version 1.3 2005/05/25 13:10:09
   ! and dyn3d/guide.h, version 1.1.1.1 2004/05/19 12:53:06
 
+  IMPLICIT NONE
+
   REAL tau_min_u, tau_max_u
   REAL tau_min_v, tau_max_v
   REAL tau_min_t, tau_max_t
@@ -12,8 +14,6 @@
 
 
   LOGICAL guide_u, guide_v, guide_t, guide_q, guide_p
-  REAL lat_min_guide, lat_max_guide
-
   LOGICAL ncep, ini_anal
   INTEGER online
 
@@ -32,11 +32,9 @@
     USE serre, ONLY : clat, clon
     USE q_sat_m, ONLY : q_sat
     USE exner_hyb_m, ONLY : exner_hyb
-    USE pression_m, ONLY : pression
     USE inigrads_m, ONLY : inigrads
     use netcdf, only: nf90_nowrite, nf90_open, nf90_close
-
-    IMPLICIT NONE
+    use tau2alpha_m, only: tau2alpha
 
     INCLUDE 'netcdf.inc'
 
@@ -87,10 +85,7 @@
     REAL unskap
     REAL tnat(ip1jmp1, llm)
 
-
-    LOGICAL first
-    SAVE first
-    DATA first/ .TRUE./
+    LOGICAL:: first = .TRUE.
 
     SAVE ucovrea1, vcovrea1, tetarea1, psrea1, qrea1
     SAVE ucovrea2, vcovrea2, tetarea2, masserea2, psrea2, qrea2
@@ -110,7 +105,7 @@
 
     ! calcul de l'humidite saturante
 
-    CALL pression(ip1jmp1, ap, bp, ps, p)
+    forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
     CALL massdair(p, masse)
     PRINT *, 'OK1'
     CALL exner_hyb(ps, p, pks, pk, pkf)
@@ -310,7 +305,7 @@
           ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a
           IF (first .AND. ini_anal) ps(ij) = a
        END DO
-       CALL pression(ip1jmp1, ap, bp, ps, p)
+       forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
        CALL massdair(p, masse)
     END IF
 
@@ -344,138 +339,4 @@
 
   END SUBROUTINE guide
 
-  !=======================================================================
-  SUBROUTINE tau2alpha(type, pim, pjm, factt, taumin, taumax, alpha)
-    !=======================================================================
-
-    USE dimens_m, ONLY : iim, jjm
-    USE paramet_m, ONLY : iip1, jjp1
-    USE comconst, ONLY : pi
-    USE comgeom, ONLY : cu_2d, cv_2d, rlatu, rlatv
-    USE serre, ONLY : clat, clon, grossismx, grossismy
-    IMPLICIT NONE
-
-    !   arguments :
-    INTEGER type
-    INTEGER pim, pjm
-    REAL factt, taumin, taumax
-    REAL dxdy_, alpha(pim, pjm)
-    REAL dxdy_min, dxdy_max
-
-    !  local :
-    REAL alphamin, alphamax, gamma, xi
-    SAVE gamma
-    INTEGER i, j, ilon, ilat
-
-    LOGICAL first
-    SAVE first
-    DATA first/ .TRUE./
-
-    REAL zdx(iip1, jjp1), zdy(iip1, jjp1)
-
-    REAL zlat
-    REAL dxdys(iip1, jjp1), dxdyu(iip1, jjp1), dxdyv(iip1, jjm)
-    COMMON /comdxdy/dxdys, dxdyu, dxdyv
-
-    IF (first) THEN
-       DO j = 2, jjm
-          DO i = 2, iip1
-             zdx(i, j) = 0.5*(cu_2d(i-1, j)+cu_2d(i, j))/cos(rlatu(j))
-          END DO
-          zdx(1, j) = zdx(iip1, j)
-       END DO
-       DO j = 2, jjm
-          DO i = 1, iip1
-             zdy(i, j) = 0.5*(cv_2d(i, j-1)+cv_2d(i, j))
-          END DO
-       END DO
-       DO i = 1, iip1
-          zdx(i, 1) = zdx(i, 2)
-          zdx(i, jjp1) = zdx(i, jjm)
-          zdy(i, 1) = zdy(i, 2)
-          zdy(i, jjp1) = zdy(i, jjm)
-       END DO
-       DO j = 1, jjp1
-          DO i = 1, iip1
-             dxdys(i, j) = sqrt(zdx(i, j)*zdx(i, j)+zdy(i, j)*zdy(i, j))
-          END DO
-       END DO
-       DO j = 1, jjp1
-          DO i = 1, iim
-             dxdyu(i, j) = 0.5*(dxdys(i, j)+dxdys(i+1, j))
-          END DO
-          dxdyu(iip1, j) = dxdyu(1, j)
-       END DO
-       DO j = 1, jjm
-          DO i = 1, iip1
-             dxdyv(i, j) = 0.5*(dxdys(i, j)+dxdys(i+1, j))
-          END DO
-       END DO
-
-       CALL dump2d(iip1, jjp1, dxdys, 'DX2DY2 SCAL  ')
-       CALL dump2d(iip1, jjp1, dxdyu, 'DX2DY2 U     ')
-       CALL dump2d(iip1, jjp1, dxdyv, 'DX2DY2 v     ')
-
-       !   coordonnees du centre du zoom
-       CALL coordij(clon, clat, ilon, ilat)
-       !   aire de la maille au centre du zoom
-       dxdy_min = dxdys(ilon, ilat)
-       !   dxdy maximale de la maille
-       dxdy_max = 0.
-       DO j = 1, jjp1
-          DO i = 1, iip1
-             dxdy_max = max(dxdy_max, dxdys(i, j))
-          END DO
-       END DO
-
-       IF (abs(grossismx-1.)<0.1 .OR. abs(grossismy-1.)<0.1) THEN
-          PRINT *, 'ATTENTION modele peu zoome'
-          PRINT *, 'ATTENTION on prend une constante de guidage cste'
-          gamma = 0.
-       ELSE
-          gamma = (dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
-          PRINT *, 'gamma=', gamma
-          IF (gamma<1.E-5) THEN
-             PRINT *, 'gamma =', gamma, '<1e-5'
-             STOP
-          END IF
-          PRINT *, 'gamma=', gamma
-          gamma = log(0.5)/log(gamma)
-       END IF
-    END IF
-
-    alphamin = factt/taumax
-    alphamax = factt/taumin
-
-    DO j = 1, pjm
-       DO i = 1, pim
-          IF (type==1) THEN
-             dxdy_ = dxdys(i, j)
-             zlat = rlatu(j)*180./pi
-          ELSE IF (type==2) THEN
-             dxdy_ = dxdyu(i, j)
-             zlat = rlatu(j)*180./pi
-          ELSE IF (type==3) THEN
-             dxdy_ = dxdyv(i, j)
-             zlat = rlatv(j)*180./pi
-          END IF
-          IF (abs(grossismx-1.)<0.1 .OR. abs(grossismy-1.)<0.1) THEN
-             !  pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
-             alpha(i, j) = alphamin
-          ELSE
-             xi = ((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
-             xi = min(xi, 1.)
-             IF (lat_min_guide<=zlat .AND. zlat<=lat_max_guide) THEN
-                alpha(i, j) = xi*alphamin + (1.-xi)*alphamax
-             ELSE
-                alpha(i, j) = 0.
-             END IF
-          END IF
-       END DO
-    END DO
-
-
-    RETURN
-  END SUBROUTINE tau2alpha
-
 END MODULE guide_m