[1992] | 1 | SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, & |
---|
| 2 | plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, wghti1, pbase1, buoybase1, & |
---|
| 3 | t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, u1, v1, gz1, th1, & |
---|
| 4 | th1_wake, tra1, h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & |
---|
| 5 | h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, sig1, w01, ptop21, & |
---|
| 6 | ale1, alp1, iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, hnk, unk, vnk, & |
---|
| 7 | wghti, pbase, buoybase, t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, & |
---|
| 8 | gz, th, th_wake, tra, h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, h_wake, & |
---|
| 9 | lv_wake, lf_wake, cpn_wake, tv_wake, sig, w0, ptop2, ale, alp) |
---|
| 10 | ! ************************************************************** |
---|
| 11 | ! * |
---|
| 12 | ! CV3A_COMPRESS * |
---|
| 13 | ! * |
---|
| 14 | ! * |
---|
| 15 | ! written by : Sandrine Bony-Lena , 17/05/2003, 11.22.15 * |
---|
| 16 | ! modified by : Jean-Yves Grandpeix, 23/06/2003, 10.28.09 * |
---|
| 17 | ! ************************************************************** |
---|
[879] | 18 | |
---|
[1992] | 19 | IMPLICIT NONE |
---|
[879] | 20 | |
---|
[1992] | 21 | include "cv3param.h" |
---|
[879] | 22 | |
---|
[1992] | 23 | ! inputs: |
---|
| 24 | INTEGER len, nloc, ncum, nd, ntra |
---|
| 25 | INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len) |
---|
| 26 | REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len) |
---|
| 27 | REAL hnk1(len), unk1(len), vnk1(len) |
---|
| 28 | REAL wghti1(len, nd), pbase1(len), buoybase1(len) |
---|
| 29 | REAL t1(len, nd), q1(len, nd), qs1(len, nd) |
---|
| 30 | REAL t1_wake(len, nd), q1_wake(len, nd), qs1_wake(len, nd) |
---|
| 31 | REAL s1_wake(len) |
---|
| 32 | REAL u1(len, nd), v1(len, nd) |
---|
| 33 | REAL gz1(len, nd), th1(len, nd), th1_wake(len, nd) |
---|
| 34 | REAL tra1(len, nd, ntra) |
---|
| 35 | REAL h1(len, nd), lv1(len, nd), lf1(len, nd), cpn1(len, nd) |
---|
| 36 | REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd) |
---|
| 37 | REAL tvp1(len, nd), clw1(len, nd) |
---|
| 38 | REAL h1_wake(len, nd), lv1_wake(len, nd), cpn1_wake(len, nd) |
---|
| 39 | REAL tv1_wake(len, nd), lf1_wake(len, nd) |
---|
| 40 | REAL sig1(len, nd), w01(len, nd), ptop21(len) |
---|
| 41 | REAL ale1(len), alp1(len) |
---|
[879] | 42 | |
---|
[1992] | 43 | ! outputs: |
---|
| 44 | ! en fait, on a nloc=len pour l'instant (cf cv_driver) |
---|
| 45 | INTEGER iflag(len), nk(len), icb(len), icbs(len) |
---|
| 46 | REAL plcl(len), tnk(len), qnk(len), gznk(len) |
---|
| 47 | REAL hnk(len), unk(len), vnk(len) |
---|
| 48 | REAL wghti(len, nd), pbase(len), buoybase(len) |
---|
| 49 | REAL t(len, nd), q(len, nd), qs(len, nd) |
---|
| 50 | REAL t_wake(len, nd), q_wake(len, nd), qs_wake(len, nd) |
---|
| 51 | REAL s_wake(len) |
---|
| 52 | REAL u(len, nd), v(len, nd) |
---|
| 53 | REAL gz(len, nd), th(len, nd), th_wake(len, nd) |
---|
| 54 | REAL tra(len, nd, ntra) |
---|
| 55 | REAL h(len, nd), lv(len, nd), lf(len, nd), cpn(len, nd) |
---|
| 56 | REAL p(len, nd), ph(len, nd+1), tv(len, nd), tp(len, nd) |
---|
| 57 | REAL tvp(len, nd), clw(len, nd) |
---|
| 58 | REAL h_wake(len, nd), lv_wake(len, nd), cpn_wake(len, nd) |
---|
| 59 | REAL tv_wake(len, nd), lf_wake(len, nd) |
---|
| 60 | REAL sig(len, nd), w0(len, nd), ptop2(len) |
---|
| 61 | REAL ale(len), alp(len) |
---|
[879] | 62 | |
---|
[1992] | 63 | ! local variables: |
---|
| 64 | INTEGER i, k, nn, j |
---|
[879] | 65 | |
---|
[1992] | 66 | CHARACTER (LEN=20) :: modname = 'cv3a_compress' |
---|
| 67 | CHARACTER (LEN=80) :: abort_message |
---|
[1403] | 68 | |
---|
[879] | 69 | |
---|
[1992] | 70 | DO k = 1, nl + 1 |
---|
| 71 | nn = 0 |
---|
| 72 | DO i = 1, len |
---|
| 73 | IF (iflag1(i)==0) THEN |
---|
| 74 | nn = nn + 1 |
---|
| 75 | wghti(nn, k) = wghti1(i, k) |
---|
| 76 | t(nn, k) = t1(i, k) |
---|
| 77 | q(nn, k) = q1(i, k) |
---|
| 78 | qs(nn, k) = qs1(i, k) |
---|
| 79 | t_wake(nn, k) = t1_wake(i, k) |
---|
| 80 | q_wake(nn, k) = q1_wake(i, k) |
---|
| 81 | qs_wake(nn, k) = qs1_wake(i, k) |
---|
| 82 | u(nn, k) = u1(i, k) |
---|
| 83 | v(nn, k) = v1(i, k) |
---|
| 84 | gz(nn, k) = gz1(i, k) |
---|
| 85 | th(nn, k) = th1(i, k) |
---|
| 86 | th_wake(nn, k) = th1_wake(i, k) |
---|
| 87 | h(nn, k) = h1(i, k) |
---|
| 88 | lv(nn, k) = lv1(i, k) |
---|
| 89 | lf(nn, k) = lf1(i, k) |
---|
| 90 | cpn(nn, k) = cpn1(i, k) |
---|
| 91 | p(nn, k) = p1(i, k) |
---|
| 92 | ph(nn, k) = ph1(i, k) |
---|
| 93 | tv(nn, k) = tv1(i, k) |
---|
| 94 | tp(nn, k) = tp1(i, k) |
---|
| 95 | tvp(nn, k) = tvp1(i, k) |
---|
| 96 | clw(nn, k) = clw1(i, k) |
---|
| 97 | h_wake(nn, k) = h1_wake(i, k) |
---|
| 98 | lv_wake(nn, k) = lv1_wake(i, k) |
---|
| 99 | lf_wake(nn, k) = lf1_wake(i, k) |
---|
| 100 | cpn_wake(nn, k) = cpn1_wake(i, k) |
---|
| 101 | tv_wake(nn, k) = tv1_wake(i, k) |
---|
| 102 | sig(nn, k) = sig1(i, k) |
---|
| 103 | w0(nn, k) = w01(i, k) |
---|
| 104 | END IF |
---|
| 105 | END DO |
---|
| 106 | END DO |
---|
[879] | 107 | |
---|
[1992] | 108 | ! AC! do 121 j=1,ntra |
---|
| 109 | ! AC!ccccc do 111 k=1,nl+1 |
---|
| 110 | ! AC! do 111 k=1,nd |
---|
| 111 | ! AC! nn=0 |
---|
| 112 | ! AC! do 101 i=1,len |
---|
| 113 | ! AC! if(iflag1(i).eq.0)then |
---|
| 114 | ! AC! nn=nn+1 |
---|
| 115 | ! AC! tra(nn,k,j)=tra1(i,k,j) |
---|
| 116 | ! AC! endif |
---|
| 117 | ! AC! 101 continue |
---|
| 118 | ! AC! 111 continue |
---|
| 119 | ! AC! 121 continue |
---|
[879] | 120 | |
---|
[1992] | 121 | IF (nn/=ncum) THEN |
---|
| 122 | PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum |
---|
| 123 | abort_message = '' |
---|
| 124 | CALL abort_gcm(modname, abort_message, 1) |
---|
| 125 | END IF |
---|
| 126 | |
---|
| 127 | nn = 0 |
---|
| 128 | DO i = 1, len |
---|
| 129 | IF (iflag1(i)==0) THEN |
---|
| 130 | nn = nn + 1 |
---|
| 131 | s_wake(nn) = s1_wake(i) |
---|
| 132 | iflag(nn) = iflag1(i) |
---|
| 133 | nk(nn) = nk1(i) |
---|
| 134 | icb(nn) = icb1(i) |
---|
| 135 | icbs(nn) = icbs1(i) |
---|
| 136 | plcl(nn) = plcl1(i) |
---|
| 137 | tnk(nn) = tnk1(i) |
---|
| 138 | qnk(nn) = qnk1(i) |
---|
| 139 | gznk(nn) = gznk1(i) |
---|
| 140 | hnk(nn) = hnk1(i) |
---|
| 141 | unk(nn) = unk1(i) |
---|
| 142 | vnk(nn) = vnk1(i) |
---|
| 143 | pbase(nn) = pbase1(i) |
---|
| 144 | buoybase(nn) = buoybase1(i) |
---|
| 145 | ptop2(nn) = ptop2(i) |
---|
[879] | 146 | ale(nn) = ale1(i) |
---|
| 147 | alp(nn) = alp1(i) |
---|
[1992] | 148 | END IF |
---|
| 149 | END DO |
---|
[879] | 150 | |
---|
[1992] | 151 | IF (nn/=ncum) THEN |
---|
| 152 | PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum |
---|
| 153 | abort_message = '' |
---|
| 154 | CALL abort_gcm(modname, abort_message, 1) |
---|
| 155 | END IF |
---|
[972] | 156 | |
---|
[1992] | 157 | RETURN |
---|
| 158 | END SUBROUTINE cv3a_compress |
---|