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