SUBROUTINE MESH( & ML, NL, NG, IDG, NGDO, IGDO, & ZA,Za_hi, nsr, ner, nl_hi, & ZT, z_hi, Pa, P_HI, Ta, T_HI, & QMIX, QMIX_HI, & EVAR, EVAR_HI, & NO_den, NO_evar, nchn, & simsig, simsig_hi, & meassig, meassig_hi, & NLEAVE, ILEAVE, & ztop, zend, zmax, zmin ) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C (c) Copyright 2001 by GATS, Inc. C 11864 Canon Blvd., Suite 101 C Newport News, VA, 23606 C (757) 873-5920 C All Rights Reserved. No part of this software or publication may be C reproduced, stored in a retrieval system, or transmitted, in any form C or by any means, electronic, mechanical, photocopying, recording, or C otherwise without the prior written permission of GATS, Inc. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT NONE INTEGER*4 ML, NL_HI, NG, NLEAVE,ILEAVE, & nchn, ich,ner,nsr, itop_T, ibottom_T, & itop_Q, ibottom_Q, isr,ier, & NL, IL,IG, idg(ng), ngdo, igdo(ngdo), k, kstart, ido REAL*4 ZA(ML),ZA_HI(ML),zmax,zmin,den, & ZT(ML),Z_HI(ML),Pa(ML),P_HI(ML), & Ta(ML),T_HI(ML),NO_den(ML), & QMIX(ML,*),QMIX_HI(ML,*), & evar(ml,*),evar_hi(ml,*),NO_evar(ml),wrk(1000),wrk2(1000), & count_T(1000), count_Q(1000) real*4 ztop(ngdo), zend(ngdo) real*8 simsig(ml,*), simsig_hi(ml,*),meassig(ml,*), & meassig_hi(ml,*) external location save count_T, count_Q c print*, "inside mesh " if(ml .gt. 1000) then print*, 'in Mesh.f ML > 1000 ' , ml, 1000 stop endif c print*,'#ileave ', ileave c do il=nsr,ner c print*, ta(il), za(il) c enddo c stop c print*,'&' c print*,'#########' c do il=1,nl c print*, simsig(il,1),meassig(il,1), zt(il) c enddo c print*,"&" c stop if(nleave .eq. 1 .and. ileave .gt. 1) then k=1 c nl_hi = nl else k=ileave c if(k .eq. nleave) nl_hi = nl*nleave endif kstart = k if(kstart .eq. 1) then do il =1, nl_hi p_hi(il)=0. t_hi(il) = 0. count_T(il) = 0. count_Q(il) = 0. do ig=1, ng qmix_hi(il,ig) = 0. enddo do ido = 1, ngdo evar_hi(il,ido) = 0. enddo enddo endif c print*, ' inside mesh ',ileave, nleave CALL location(z_hi,nl_hi,za(nsr), itop_T) if(z_hi(itop_T) > za(nsr) ) itop_T = itop_T +1 c print*, z_hi(1), z_hi(itop_t) c stop CALL location(z_hi,nl_hi,za(ner), ibottom_T) CALL KP_INTPROF_noxtrp(nl_hi,nl,itop_T,ibottom_T ,Za,Z_hi,ta, & wrk ) c print*, za(nsr), za(ner), z_hi(itop_t), z_hi(ibottom_t) c stop do il = itop_T, ibottom_T t_hi(il) = t_hi(il)+wrk(il) count_T(il) = count_T(il) + 1. c print*,t_hi(il), z_hi(il) enddo c stop c lets interpolate in log pressure do il=1, nl wrk2(il) = log(pa(il) ) enddo CALL KP_INTPROF_noxtrp(nl_hi,nl,itop_T,ibottom_T,Za,z_hi,wrk2, & wrk ) do il = itop_T, ibottom_T p_hi(il) = p_hi(il)+ wrk(il) enddo do ig = 1,ng CALL location(z_hi,nl_hi,zt(nsr), itop_Q) if(z_hi(itop_Q) > zt(nsr) ) itop_Q = itop_Q +1 CALL location(z_hi,nl_hi,zt(ner), ibottom_Q) CALL KP_INTPROF_noxtrp(nl_hi,nl,itop_Q,ibottom_Q,Zt,z_hi, & qmix(1,ig),wrk ) do il = itop_Q, ibottom_Q if(ig .eq. 1) count_Q(il) = count_Q(il) + 1. qmix_hi(il,ig) = qmix_hi(il,ig)+ wrk(il) enddo enddo do ido=1, ngdo if(igdo(ido) .lt. 0) then isr = itop_T ier = ibottom_T CALL KP_INTPROF_noxtrp(nl_hi,nl,isr,ier,Za,z_hi, & evar(1,ido), wrk ) C print*,nl_hi,nl,isr,ier C do il=1,nl C print*,Za(il),evar(il,ido) C enddo C print*,wrk else isr=itop_Q ier = ibottom_Q CALL KP_INTPROF_noxtrp(nl_hi,nl,isr,ier,Zt,z_hi, & evar(1,ido), wrk ) endif do il = isr, ier evar_hi(il,ido) = evar_hi(il,ido)+wrk(il) enddo enddo do il=1, nl za_hi(k) = za(il) do ich=1,nchn simsig_hi(k,ich) = simsig(il,ich) meassig_hi(k,ich) = meassig(il,ich) enddo k=k+nleave enddo c do ido=1, ngdo c if(igdo(ido) .lt. 0) then c zbot(ido) = max(za(ner),zbot(ido) ) c else c zbot(ido) = max(zt(ner),zbot(ido) ) c endif c enddo c All interleaves completed - Calculate averages if(kstart .eq. nleave ) then c do il=1,nl_hi c print*,z_hi(il), simsig_hi(il,1),meassig_hi(il,1) c print*, z_hi(il),1./(evar_hi(il,1)/nleave) c enddo do ido=1,ngdo wrk(ido) = -150. wrk2(ido) = 10000. enddo c zmin = -150. c zmax = 10000. do il = 1, nl_hi c since p_hi is in log pressure we need to exp it to get the values in mb den=0.0 if(count_T(il) > 0.9) then t_hi(il) = t_hi(il)/count_T(il) p_hi(il) = exp(p_hi(il) / count_T(il) ) if(t_hi(il).gt.80.0.and.t_hi(il).lt.1000.0) then den=7.243e18*p_hi(il)/t_hi(il) else den=-1.0e24 endif endif do ig = 1, ng if(count_Q(il) .gt. 0.9) Then qmix_hi(il,ig) = qmix_hi(il,ig) / count_Q(il) if(idg(ig) .eq. 800) Then if(qmix_hi(il,ig).gt.1.0e-14.and.den.gt.0.0) Then NO_den(il)=den*qmix_hi(il,ig) Else NO_den(il)=-1.0e24 Endif c print*,il,p_hi(il),den,NO_den(il) Endif Endif enddo c print*, qmix_hi(il,1), qmix_hi(il,2), z_hi(il) do ido=1, ngdo if(igdo(ido) .lt. 0) then if(count_T(il) > 0.9) then wrk(ido) = max(wrk(ido), z_hi(il) ) wrk2(ido) = min(wrk2(ido), z_hi(il) ) evar_hi(il,ido) = evar_hi(il,ido) / count_T(il) endif else if(count_Q(il) > 0.9) then wrk(ido) = max(wrk(ido), z_hi(il) ) wrk2(ido) = min(wrk2(ido), z_hi(il) ) evar_hi(il,ido) = evar_hi(il,ido) / count_Q(il) if(igdo(ido) .eq. 800) Then if (evar_hi(il,ido).ge.0.0.and.den.gt.0.0) Then NO_evar(il)=den*evar_hi(il,ido) Else NO_evar(il)=evar_hi(il,ido) Endif Endif endif endif enddo enddo c stop c print*,ztop(1), zend(1), wrk(1) ,wrk2(1) do ido=1,ngdo zmin = max(zmin, wrk2(ido) ) if(zend(ido) .gt. 0.) zend(ido) = max(wrk2(ido), & zend(ido)) zmax = min(zmax,wrk(ido) ) if(ztop(ido) .gt. 0.) ztop(ido) = min(ztop(ido), & wrk(ido) ) enddo c print*, zmax, ztop(1), zmin, zend(1) c stop c stop c do il=1,nl_hi c if(count_T(il) > 0.9 ) print*, t_hi(il), c & p_hi(il) c enddo c print*,"&" c stop c if( igdo(ngdo) .lt. 0 ) then c call location(z_hi, nl_hi, zreg, iptie_hi) c if(iptie_hi .eq. 0) iptie_hi = 1 c print*,'Mesh: zreg, za(iptie)', zreg, za_hi(iptie_hi) c endif endif RETURN END