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