source: LMDZ5/trunk/libf/phylmd/cv3a_compress.F90 @ 2051

SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
    plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, wghti1, pbase1, buoybase1, &
    t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, u1, v1, gz1, th1, &
    th1_wake, tra1, h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
    h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, sig1, w01, ptop21, &
    ale1, alp1, iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, hnk, unk, vnk, &
    wghti, pbase, buoybase, t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, &
    gz, th, th_wake, tra, h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, h_wake, &
    lv_wake, lf_wake, cpn_wake, tv_wake, sig, w0, ptop2, ale, alp)
  ! **************************************************************
  ! *
  ! CV3A_COMPRESS                                               *
  ! *
  ! *
  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
  ! **************************************************************

  IMPLICIT NONE

  include "cv3param.h"

  ! inputs:
  INTEGER len, nloc, ncum, nd, ntra
  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
  REAL hnk1(len), unk1(len), vnk1(len)
  REAL wghti1(len, nd), pbase1(len), buoybase1(len)
  REAL t1(len, nd), q1(len, nd), qs1(len, nd)
  REAL t1_wake(len, nd), q1_wake(len, nd), qs1_wake(len, nd)
  REAL s1_wake(len)
  REAL u1(len, nd), v1(len, nd)
  REAL gz1(len, nd), th1(len, nd), th1_wake(len, nd)
  REAL tra1(len, nd, ntra)
  REAL h1(len, nd), lv1(len, nd), lf1(len, nd), cpn1(len, nd)
  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
  REAL tvp1(len, nd), clw1(len, nd)
  REAL h1_wake(len, nd), lv1_wake(len, nd), cpn1_wake(len, nd)
  REAL tv1_wake(len, nd), lf1_wake(len, nd)
  REAL sig1(len, nd), w01(len, nd), ptop21(len)
  REAL ale1(len), alp1(len)

  ! outputs:
  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
  INTEGER iflag(len), nk(len), icb(len), icbs(len)
  REAL plcl(len), tnk(len), qnk(len), gznk(len)
  REAL hnk(len), unk(len), vnk(len)
  REAL wghti(len, nd), pbase(len), buoybase(len)
  REAL t(len, nd), q(len, nd), qs(len, nd)
  REAL t_wake(len, nd), q_wake(len, nd), qs_wake(len, nd)
  REAL s_wake(len)
  REAL u(len, nd), v(len, nd)
  REAL gz(len, nd), th(len, nd), th_wake(len, nd)
  REAL tra(len, nd, ntra)
  REAL h(len, nd), lv(len, nd), lf(len, nd), cpn(len, nd)
  REAL p(len, nd), ph(len, nd+1), tv(len, nd), tp(len, nd)
  REAL tvp(len, nd), clw(len, nd)
  REAL h_wake(len, nd), lv_wake(len, nd), cpn_wake(len, nd)
  REAL tv_wake(len, nd), lf_wake(len, nd)
  REAL sig(len, nd), w0(len, nd), ptop2(len)
  REAL ale(len), alp(len)

  ! local variables:
  INTEGER i, k, nn, j

  CHARACTER (LEN=20) :: modname = 'cv3a_compress'
  CHARACTER (LEN=80) :: abort_message


  DO k = 1, nl + 1
    nn = 0
    DO i = 1, len
      IF (iflag1(i)==0) THEN
        nn = nn + 1
        wghti(nn, k) = wghti1(i, k)
        t(nn, k) = t1(i, k)
        q(nn, k) = q1(i, k)
        qs(nn, k) = qs1(i, k)
        t_wake(nn, k) = t1_wake(i, k)
        q_wake(nn, k) = q1_wake(i, k)
        qs_wake(nn, k) = qs1_wake(i, k)
        u(nn, k) = u1(i, k)
        v(nn, k) = v1(i, k)
        gz(nn, k) = gz1(i, k)
        th(nn, k) = th1(i, k)
        th_wake(nn, k) = th1_wake(i, k)
        h(nn, k) = h1(i, k)
        lv(nn, k) = lv1(i, k)
        lf(nn, k) = lf1(i, k)
        cpn(nn, k) = cpn1(i, k)
        p(nn, k) = p1(i, k)
        ph(nn, k) = ph1(i, k)
        tv(nn, k) = tv1(i, k)
        tp(nn, k) = tp1(i, k)
        tvp(nn, k) = tvp1(i, k)
        clw(nn, k) = clw1(i, k)
        h_wake(nn, k) = h1_wake(i, k)
        lv_wake(nn, k) = lv1_wake(i, k)
        lf_wake(nn, k) = lf1_wake(i, k)
        cpn_wake(nn, k) = cpn1_wake(i, k)
        tv_wake(nn, k) = tv1_wake(i, k)
        sig(nn, k) = sig1(i, k)
        w0(nn, k) = w01(i, k)
      END IF
    END DO
  END DO

  ! AC!      do 121 j=1,ntra
  ! AC!ccccc      do 111 k=1,nl+1
  ! AC!      do 111 k=1,nd
  ! AC!       nn=0
  ! AC!      do 101 i=1,len
  ! AC!      if(iflag1(i).eq.0)then
  ! AC!       nn=nn+1
  ! AC!       tra(nn,k,j)=tra1(i,k,j)
  ! AC!      endif
  ! AC! 101  continue
  ! AC! 111  continue
  ! AC! 121  continue

  IF (nn/=ncum) THEN
    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
    abort_message = ''
    CALL abort_gcm(modname, abort_message, 1)
  END IF

  nn = 0
  DO i = 1, len
    IF (iflag1(i)==0) THEN
      nn = nn + 1
      s_wake(nn) = s1_wake(i)
      iflag(nn) = iflag1(i)
      nk(nn) = nk1(i)
      icb(nn) = icb1(i)
      icbs(nn) = icbs1(i)
      plcl(nn) = plcl1(i)
      tnk(nn) = tnk1(i)
      qnk(nn) = qnk1(i)
      gznk(nn) = gznk1(i)
      hnk(nn) = hnk1(i)
      unk(nn) = unk1(i)
      vnk(nn) = vnk1(i)
      pbase(nn) = pbase1(i)
      buoybase(nn) = buoybase1(i)
      ptop2(nn) = ptop2(i)
      ale(nn) = ale1(i)
      alp(nn) = alp1(i)
    END IF
  END DO

  IF (nn/=ncum) THEN
    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
    abort_message = ''
    CALL abort_gcm(modname, abort_message, 1)
  END IF

  RETURN
END SUBROUTINE cv3a_compress