PGF90 (Version 12.8) 08/30/2020 00:27:53 page 1 Switches: -noasm -nodclchk -nodebug -nodlines -noline -list -idir ../include -inform warn -opt 1 -nosave -object -noonetrip -depchk on -nostandard -nosymbol -noupcase Filename: qu2ll.f90 ( 1) subroutine qu2ll ( 2) ( 3) USE mod_extra ( 4) implicit none ( 5) include 'param_o.h' ( 6) !! include 'extra.comm' ( 7) ( 8) !!JNT real, dimension(0:im+1,0:jm+1,nm,lsm)::fsl,usl,vsl,ull,vll,qsl,tsl,q2sl ( 9) !!JNT real, dimension(igm,jgm,lsm)::fsl_ll,hgt_ll,usp,vsp,qsl_ll,tsl_ll,q2sl_ll ( 10) !!JNT real, dimension(igm,jgm)::psurf_ll,tsfc_ll,pslp_ll,acprec_ll ( 11) !!JNT real, dimension(0:im+1,0:jm+1,nm)::tsfc,acprec ( 12) ../include/param_o.h ( 1)* integer,parameter :: im0=401 ( 2)* integer, parameter :: nm=6 ( 3)* integer, parameter :: lm = 50 ( 4)* integer, parameter :: nsub = 10 ( 5)* ( 6)* integer, parameter :: im=im0, jm=im ( 7)* integer, parameter :: im1=im-1, jm1=jm-1 ( 8)* ( 9)* integer, parameter :: lm1 = lm-1, lp1 =lm +1 ( 10)* ( 11)* integer, parameter :: ixm = nsub, jym = ixm, nxy = ixm*jym ( 12)* integer, parameter :: ildom = (im - 1)/ixm, jldom = (jm - 1)/jym ( 13)* integer, parameter :: ilm = (im - 1)/ixm +1, jlm = (jm - 1)/jym +1 ( 14)* ( 15)* logical,parameter::flat=.false. ( 16)* logical,parameter::hstst=.false. ( 17)* ( 18)*! integer,parameter::igm=360, jgm = 181 ( 19)* integer,parameter::igm=(im0-1)*4, jgm = (igm/2)+1 ( 20)* real,parameter::alfa=0.0, beta=0.0, gamm=0.0 ( 21)*! real,parameter::alfa=0.*3.1415926/180.,beta=66.*3.1415926/180. & ( 22)*! ,gamm=175.*3.1415926/180. ( 23)* ( 24)*!GSM integer,parameter::lsm=20 ( 25)* integer,parameter::lsm=31 ( 26)* ( 27)*!RESTART ( 28)* ( 29)* character(len=10):: restartdate='2020080412' !restart date to create appropriate folder name ( 13) real, allocatable, save, dimension(:,:,:,:)::fsl,usl,vsl,ull,vll,qsl,tsl,q2sl ( 14) real, allocatable, save, dimension(:,:,:)::fsl_ll,hgt_ll,usp,vsp,qsl_ll,tsl_ll,q2sl_ll ( 15) real, allocatable, save, dimension(:,:)::psurf_ll,tsfc_ll,pslp_ll,acprec_ll ( 16) real, allocatable, save, dimension(:,:,:)::tsfc,acprec ( 17) logical, save :: FIRST=.true. ( 18) integer::l,i,j,n,k ( 19) ( 20) if (FIRST) then ( 21) ALLOCATE(fsl(0:im+1,0:jm+1,nm,lsm)) PGF90 (Version 12.8) 08/30/2020 00:27:53 page 2 ( 22) ALLOCATE(usl(0:im+1,0:jm+1,nm,lsm)) ( 23) ALLOCATE(vsl(0:im+1,0:jm+1,nm,lsm)) ( 24) ALLOCATE(ull(0:im+1,0:jm+1,nm,lsm)) ( 25) ALLOCATE(vll(0:im+1,0:jm+1,nm,lsm)) ( 26) ALLOCATE(qsl(0:im+1,0:jm+1,nm,lsm)) ( 27) ALLOCATE(tsl(0:im+1,0:jm+1,nm,lsm)) ( 28) ALLOCATE(q2sl(0:im+1,0:jm+1,nm,lsm)) ( 29) ( 30) ALLOCATE(fsl_ll(igm,jgm,lsm)) ( 31) ALLOCATE(hgt_ll(igm,jgm,lsm)) ( 32) ALLOCATE(usp(igm,jgm,lsm)) ( 33) ALLOCATE(vsp(igm,jgm,lsm)) ( 34) ALLOCATE(qsl_ll(igm,jgm,lsm)) ( 35) ALLOCATE(tsl_ll(igm,jgm,lsm)) ( 36) ALLOCATE(q2sl_ll(igm,jgm,lsm)) ( 37) ( 38) ALLOCATE(psurf_ll(igm,jgm)) ( 39) ALLOCATE(tsfc_ll(igm,jgm)) ( 40) ALLOCATE(pslp_ll(igm,jgm)) ( 41) ALLOCATE(acprec_ll(igm,jgm)) ( 42) ALLOCATE(tsfc(0:im+1,0:jm+1,nm)) ( 43) ALLOCATE(acprec(0:im+1,0:jm+1,nm)) ( 44) ( 45) FIRST = .false. ( 46) endif ( 47) open(1,file='tmpfld.dat',form='unformatted') ( 48) do l=1,lsm ( 49) read(1)fsl(:,:,:,l) ( 50) read(1)usl(:,:,:,l) ( 51) read(1)vsl(:,:,:,l) ( 52) ! read(1)qsl(:,:,:,l) ( 53) read(1)tsl(:,:,:,l) ( 54) read(1)q2sl(:,:,:,l) ( 55) enddo ( 56) close(1) ( 57) ( 58) open(1,file='tmpsfc.dat',form='unformatted') ( 59) read(1)tsfc ( 60) read(1)acprec ( 61) close(1) ( 62) ( 63) if(nm.eq.14)then ( 64) call octa2llH(fsl, fsl_ll, lsm) ( 65) call octa2llH(qsl, qsl_ll, lsm) ( 66) call octa2llH(tsl, tsl_ll, lsm) ( 67) call octa2llH(q2sl, q2sl_ll, lsm) ( 68) call octa2llH(pint(:,:,:,lp1),psurf_ll,1) ( 69) call octa2llH(pslp,pslp_ll,1) ( 70) call octa2llH(tsfc,tsfc_ll,1) ( 71) call octa2llH(acprec,acprec_ll,1) ( 72) call llwinds_oc(usl, vsl, ull, vll,lsm) ( 73) call bocovs_oc(ull,im,jm,lsm) ( 74) call bocovs_oc(vll,im,jm,lsm) ( 75) call avrv_oc(ull, usl,lsm) ( 76) call avrv_oc(vll, vsl,lsm) ( 77) usl = usl * .25 ( 78) vsl = vsl * .25 ( 79) do k=1,nm PGF90 (Version 12.8) 08/30/2020 00:27:53 page 3 ( 80) if(k.eq.1.or.k.eq.2.or.k.eq.7.or.k.eq.8.or.k.eq.9 & ( 81) .or.k.eq.12)then ( 82) usl(1 ,1 ,k,:)=usl(1 ,1 ,k,:)*4./3. ( 83) vsl(1 ,1 ,k,:)=vsl(1 ,1 ,k,:)*4./3. ( 84) endif ( 85) ( 86) if(k.eq.1.or.k.eq.4.or.k.eq.6.or.k.eq.7.or.k.eq.11 & ( 87) .or.k.eq.14)then ( 88) usl(im,1 ,k,:)=usl(im,1 ,k,:)*4./3. ( 89) vsl(im,1 ,k,:)=vsl(im,1 ,k,:)*4./3. ( 90) endif ( 91) ( 92) if(k.eq.2.or.k.eq.5.or.k.eq.6.or.k.eq.9.or.k.eq.13 & ( 93) .or.k.eq.14)then ( 94) usl(1 ,jm,k,:)=usl(1 ,jm,k,:)*4./3. ( 95) vsl(1 ,jm,k,:)=vsl(1 ,jm,k,:)*4./3. ( 96) endif ( 97) ( 98) if(k.eq.4.or.k.eq.5.or.k.eq.8.or.k.eq.11.or.k.eq.12 & ( 99) .or.k.eq.13)then ( 100) usl(im,jm,k,:)=usl(im,jm,k,:)*4./3. ( 101) vsl(im,jm,k,:)=vsl(im,jm,k,:)*4./3. ( 102) endif ( 103) enddo ( 104) ( 105) call octa2llH(usl, usp, lsm) ( 106) call octa2llH(vsl, vsp, lsm) ( 107) ( 108) else if(nm.eq.6)then ( 109) call cube2llH(fsl, fsl_ll, lsm) ( 110) call cube2llH(qsl, qsl_ll, lsm) ( 111) call cube2llH(tsl, tsl_ll, lsm) ( 112) call cube2llH(q2sl, q2sl_ll, lsm) ( 113) call cube2llH(pint(:,:,:,lp1),psurf_ll,1) ( 114) call cube2llH(pslp,pslp_ll,1) ( 115) call cube2llH(tsfc,tsfc_ll,1) ( 116) call cube2llH(acprec,acprec_ll,1) ( 117) call llwinds(usl, vsl, ull, vll,lsm) ( 118) call bocovs(ull,im,jm,lsm) ( 119) call bocovs(vll,im,jm,lsm) ( 120) call avrv(ull, usl,lsm) ( 121) call avrv(vll, vsl,lsm) ( 122) usl = usl * .25 ( 123) vsl = vsl * .25 ( 124) do k=1,nm ( 125) usl(1 ,1 ,k,:)=usl(1 ,1 ,k,:)*4./3. ( 126) vsl(1 ,1 ,k,:)=vsl(1 ,1 ,k,:)*4./3. ( 127) usl(im,1 ,k,:)=usl(im,1 ,k,:)*4./3. ( 128) vsl(im,1 ,k,:)=vsl(im,1 ,k,:)*4./3. ( 129) usl(1 ,jm,k,:)=usl(1 ,jm,k,:)*4./3. ( 130) vsl(1 ,jm,k,:)=vsl(1 ,jm,k,:)*4./3. ( 131) usl(im,jm,k,:)=usl(im,jm,k,:)*4./3. ( 132) vsl(im,jm,k,:)=vsl(im,jm,k,:)*4./3. ( 133) enddo ( 134) ( 135) call cube2llH(usl, usp, lsm) ( 136) call cube2llH(vsl, vsp, lsm) ( 137) endif PGF90 (Version 12.8) 08/30/2020 00:27:53 page 4 ( 138) ( 139) hgt_ll=fsl_ll/9.80616 ( 140) ( 141) write(10)hgt_ll(:,:,10) ( 142) ( 143) ! write(9)pslp_ll ( 144) ! write(9)psurf_ll ( 145) ! write(9)tsl_ll ( 146) ! write(9)qsl_ll ( 147) ! write(9)q2sl_ll ( 148) ! print *,'tsl_ll,256,128,',tsl_ll(256,128,1) ( 149) ( 150) do l=1,lsm ( 151) ! write(9)usp(:,:,l) ( 152) ! write(9)hgt_ll(:,:,l) ( 153) enddo ( 154) ( 155) print *,'usp,vsp,',usp(1,90,1),vsp(1,90,1) ( 156) ( 157) do l=1,lsm ( 158) ! write(9)vsp(:,:,l) ( 159) enddo ( 160) ( 161) do l=1,lsm ( 162) ! write(9)tsl_ll(:,:,l) ( 163) !DRAGAN 17.09. write(9)q2sl_ll(:,:,l) ( 164) enddo ( 165) ! ( 166) ! write(9)acprec_ll*1000 ( 167) ( 168) ! print *,pslp_ll(261,110) ( 169) ( 170) ( 171) end subroutine qu2ll