PARAMETER (IM=300,JM=300,KM=64,LMD=169) PARAMETER (KMD=51) REAL XLAT(IM,JM) ! XLAT REAL XLONG(IM,JM) ! XLONG REAL HGT(IM,JM) ! HGT REAL LANDMASK(IM,JM) ! LANDMASK REAL U(IM+1,JM,KM) ! U REAL V(IM,JM+1,KM) ! V REAL W(IM,JM,KM+1) ! W REAL GPH(IM,JM,KM+1) ! Geopotenrial height [=(PH+PHB)/9.81] REAL T(IM,JM,KM) ! potential temperature perturbation (-300K) REAL P(IM,JM,KM) ! perturbation pressure REAL PB(IM,JM,KM) ! perturbation pressure REAL QV(IM,JM,KM) ! QV REAL QC(IM,JM,KM) ! QC REAL QR(IM,JM,KM) ! QR REAL QI(IM,JM,KM) ! QI REAL QS(IM,JM,KM) ! QS REAL QG(IM,JM,KM) ! QG REAL HAGLD(IM,JM,KM+1) ! Geopotenrial height (stagger level) REAL HAGL(IM,JM,KM) ! Geopotenrial height (center level) !***** KBTM(I,J): lowest layer above the surface REAL ZD(KMD) ! data level !***************************************************** REAL FC1(IM,JM,KMD),FC2(IM,JM,KMD) REAL FCW1(IM,JM,KMD),FCW2(IM,JM,KMD) INTEGER KS(IM,JM,KMD) ! INTEGER KSW(IM,JM,KMD) ! !******** Interpolated data ******************** REAL UI(IM,JM,KMD) ! U REAL VI(IM,JM,KMD) ! U REAL WI(IM,JM,KMD) ! U REAL TI(IM,JM,KMD) ! U REAL PI(IM,JM,KMD) ! U REAL QVI(IM,JM,KMD) ! U REAL QCI(IM,JM,KMD) ! U REAL QRI(IM,JM,KMD) ! U REAL QII(IM,JM,KMD) ! U REAL QSI(IM,JM,KMD) ! U REAL QGI(IM,JM,KMD) ! U INTEGER ID,JD,I,J,K,JY,M,L !****************** DZ=100. ! original Z-grid spacing (km) !******************* irecin=0 irecin1=0 irecin2=0 irecin3=0 irecin4=0 irec=0 ! open input data file open (10,file='hgt_latlon_d01.dat' * ,form='unformatted',access='direct',recl=im*4) ! open input gph file open (20,file='w_gph_d01.dat' * ,form='unformatted',access='direct',recl=im*4) ! open input data file open (22,file='u_d01.dat' * ,form='unformatted',access='direct',recl=(im+1)*4) ! open input data file open (24,file='v_d01.dat' * ,form='unformatted',access='direct',recl=im*4) open (26,file='scalar3d_d01.dat' * ,form='unformatted',access='direct',recl=im*4) ! open output data file open (30,file='interp_AGL_d01.dat' * ,form='unformatted',access='direct',recl=im*4) pai=3.141592 z0=50. dz=100. do k=1,kmd zd(k)=z0+dz*float(k-1) end do !****************************************************************** do j=1,jm irecin=irecin+1 read(10,rec=irecin) (XLAT(i,j),i=1,im) end do do j=1,jm irecin=irecin+1 read(10,rec=irecin) (XLONG(i,j),i=1,im) end do do j=1,jm irecin=irecin+1 read(10,rec=irecin) (HGT(i,j),i=1,im) end do do j=1,jm irecin=irecin+1 read(10,rec=irecin) (LANDMASK(i,j),i=1,im) end do !****************************************************************** do 8000 L=1,LMD write(6,*)'L=',L write(6,*)'READ INPUT DATA' ! do k=1,km+1 do j=1,jm irecin1=irecin1+1 read(20,rec=irecin1) (W(i,j,k),i=1,im) end do end do do k=1,km+1 do j=1,jm irecin1=irecin1+1 read(20,rec=irecin1) (GPH(i,j,k),i=1,im) end do end do ! do k=1,km do j=1,jm irecin2=irecin2+1 read(22,rec=irecin2) (U(i,j,k),i=1,im+1) end do end do ! do k=1,km do j=1,jm+1 irecin3=irecin3+1 read(24,rec=irecin3) (V(i,j,k),i=1,im) end do end do ! do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (T(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (P(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (PB(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QV(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QC(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QR(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QI(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QS(i,j,k),i=1,im) end do end do do k=1,km do j=1,jm irecin4=irecin4+1 read(26,rec=irecin4) (QG(i,j,k),i=1,im) end do end do !******************************************************* ! vertical gph & w AGL level (from 0) do k=1,km+1 do j=1,jm do i=1,im HAGLD(i,j,k)=GPH(i,j,k)-GPH(i,j,1) end do end do end do ! u,v,scalar level do k=1,km do j=1,jm do i=1,im HAGL(i,j,k)=0.5*HAGLD(i,j,k+1)+0.5*HAGLD(i,j,k) end do end do end do do k=1,kmd do j=1,jm do i=1,im do m=1,km IF (HAGLD(I,J,M+1)-ZD(K).ge.0.0.AND.ZD(K)-HAGLD(I,J,M).gt.0) * then KSW(I,J,K)=M go to 30 end if 30 continue end do end do end do end do do k=1,kmd do j=1,jm do i=1,im do m=1,km IF (HAGL(I,J,M+1)-ZD(K).ge.0.0.AND.ZD(K)-HAGL(I,J,M).gt.0) * then KS(I,J,K)=M go to 33 end if 33 continue end do end do end do end do ! write(6,*) 'K,KS(100,100,K),KSW(100,100,K)' ! do k=1,kmd ! write(6,*) K,KS(100,100,K),KSW(100,100,K) ! end do do k=1,kmd do j=1,jm do i=1,im fc1(i,j,k)=(ZD(K)-HAGL(I,J,KS(I,J,K))) * /(HAGL(I,J,KS(I,J,K)+1)-HAGL(I,J,KS(I,J,K))) fc2(i,j,k)=(HAGL(I,J,KS(I,J,K)+1)-ZD(K)) * /(HAGL(I,J,KS(I,J,K)+1)-HAGL(I,J,KS(I,J,K))) fcw1(i,j,k)=(ZD(K)-HAGLD(I,J,KSW(I,J,K))) * /(HAGLD(I,J,KSW(I,J,K)+1)-HAGLD(I,J,KSW(I,J,K))) fcw2(i,j,k)=(HAGLD(I,J,KSW(I,J,K)+1)-ZD(K)) * /(HAGLD(I,J,KSW(I,J,K)+1)-HAGLD(I,J,KSW(I,J,K))) end do end do end do ! write(6,*) 'K,fc1,fc2,fcw1,fcw2(10,10,K)' ! do k=1,kmd ! write(6,*) K,fc1(10,10,K),fc2(10,10,K),fcw1(10,10,K),fcw2(10,10,K) ! end do do k=1,kmd do j=1,jm do i=1,im UI(I,J,K)=0.5*U(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +0.5*U(I,J,KS(I,J,K))*fc2(i,j,k) * +0.5*U(I+1,J,KS(I,J,K)+1)*fc1(i,j,k) * +0.5*U(I+1,J,KS(I,J,K))*fc2(i,j,k) VI(I,J,K)=0.5*V(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +0.5*V(I,J,KS(I,J,K))*fc2(i,j,k) * +0.5*V(I,J+1,KS(I,J,K)+1)*fc1(i,j,k) * +0.5*V(I,J+1,KS(I,J,K))*fc2(i,j,k) WI(I,J,K)=W(I,J,KSW(I,J,K)+1)*fcw1(i,j,k) * +W(I,J,KSW(I,J,K))*fcw2(i,j,k) TI(I,J,K)=T(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +T(I,J,KS(I,J,K))*fc2(i,j,k) PI(I,J,K)=P(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +P(I,J,KS(I,J,K))*fc2(i,j,k) * +PB(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +PB(I,J,KS(I,J,K))*fc2(i,j,k) QVI(I,J,K)=QV(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QV(I,J,KS(I,J,K))*fc2(i,j,k) QCI(I,J,K)=QC(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QC(I,J,KS(I,J,K))*fc2(i,j,k) QRI(I,J,K)=QR(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QR(I,J,KS(I,J,K))*fc2(i,j,k) QII(I,J,K)=QI(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QI(I,J,KS(I,J,K))*fc2(i,j,k) QSI(I,J,K)=QS(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QS(I,J,KS(I,J,K))*fc2(i,j,k) QGI(I,J,K)=QG(I,J,KS(I,J,K)+1)*fc1(i,j,k) * +QG(I,J,KS(I,J,K))*fc2(i,j,k) end do end do end do ! write(6,*) 'K,UI(100,100,K)' ! do k=1,kmd ! write(6,*) K,UI(100,100,K) ! end do !******************************* ! THH=1e9 ! do k=1,kmd ! do j=1,jm ! do i=1,im ! if (abs(UI(i,j,k)).gt.THH) THEN ! UI(i,j,k)=1e30 ! end if ! end do ! end do ! end do !******************************* do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (UI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (VI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (WI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (TI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (PI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QVI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QCI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QRI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QII(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QSI(i,j,k),i=1,im) end do end do do k=1,kmd do j=1,jm irec=irec+1 write(30,rec=irec) (QGI(i,j,k),i=1,im) end do end do 8000 continue stop end ! *******************************************