subroutine ss2gghur(idrt,im,jm,jcap,levs,ntrac,nc) c USE setparms; USE sfcio_module type(sfcio_head):: head type(sfcio_data):: data c PARAMETER(FV= 4.6150E+2 / 2.8705E+2 -1.) c real(4), allocatable :: s0_4byte(:) c real(4), allocatable :: s1_4byte(:,:) c real(4), allocatable :: s2_4byte(:,:) real(4), allocatable :: s0(:) real(4), allocatable :: s1(:,:) real(4), allocatable :: s2(:,:) real,allocatable :: u(:,:),v(:,:),t(:,:),r(:,:),tv(:,:) real,allocatable :: qs(:,:),uvtr(:,:) real gz(im*jm),gps(im*jm),gtst(im,jm),glsm(im,jm) integer, parameter :: iosfc=11,iosig=12 c real s0(nc),s1(nc,levs),s2(nc,levs) c print *,'Beginning of ss2gghur....' print *,'idrt im jm jcap = ',idrt,im,jm,jcap print *,'levs ntrac nc = ',levs,ntrac,nc allocate (s0(nc),stat=istat) if (istat /= 0) then print *,'!!! ERROR ALLOCATING s0 in ss2gghur....' return endif c allocate (uvtr(im*jm,levs),stat=iuvtra) if (iuvtra /= 0) then print *,' ' print *,'!!! ERROR ALLOCATING uvtr ARRAY in ss2gghur.' print *,'!!! iuvtra= ',iuvtra return endif c in=1 is=im*(jm-1)+1 c Do sptez for zstar and pstar. Read the variables into c the 4-byte arrays, then copy over to 8-byte arrays... read(iosig) s0 c s0 = s0_4byte print *,'Just before sptez call, ' print *,'idrt im jm jcap = ',idrt,im,jm,jcap call sptez(0,jcap,idrt,im,jm,s0,gz,1) read(iosig) s0 c s0 = s0_4byte call sptez(0,jcap,idrt,im,jm,s0,gps,1) deallocate (s0) c Change ln pstar to pstar & height units... do ij=1,im*jm gps(ij)=10.*exp(gps(ij)) gz (ij)=100.*gz (ij) enddo c Now do virtual temp. Again, read the data in as 4-byte c reals and copy into 8-byte arrays... allocate (tv(im*jm,levs),stat=itva) allocate (s1(nc,levs),stat=istat) if (istat /= 0 .or. itva /= 0) then print *,'!!! ERROR ALLOCATING s1 or tv array' print *,'!!! in ss2gghur....' print *,'!!! istat = ',istat,' itva= ',itva return endif do k=1,levs read(iosig) (s1(i,k),i=1,nc) enddo c s1 = s1_4byte call sptran(0,jcap,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, & s1,tv(in,1),tv(is,1),1) c now read in vort & divg and compute u(93)-v(91) pairs... allocate (u(im*jm,levs),stat=iua) allocate (v(im*jm,levs),stat=iva) allocate (s2(nc,levs),stat=istat) if (istat /= 0 .or. iua /= 0 .or. iva /= 0) then print *,'!!! ERROR ALLOCATING s2, u or v array' print *,'!!! in ss2gghur.' print *,'!!! istat= ',istat,' iua= ',iua,' iva= ',iva return endif do k=1,levs read(iosig) (s1(i,k),i=1,nc) read(iosig) (s2(i,k),i=1,nc) enddo c s1 = s1_4byte c s2 = s2_4byte call sptranv(0,jcap,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, & s1,s2,u(in,1),u(is,1),v(in,1),v(is,1),1) c Change to cgs do k=1,levs do ij=1,im*jm u(ij,k)=100.*u(ij,k) v(ij,k)=100.*v(ij,k) enddo enddo c Now reaarrange level structure of u and v, c reaarrange into uvtr, write them out to the c gaussian file, and deallocate the u and v c arrays.... nrgfdl=1 npints=im*jm c u comp idim1 = size(uvtr,dim=1) jdim1 = size(uvtr,dim=2) do k = 1,levs ko = levs-k+1 do ij = 1,im*jm uvtr(ij,k) = u(ij,ko) enddo enddo idim1 = size(uvtr,dim=1) jdim1 = size(uvtr,dim=2) do k=1,levs write(30) (uvtr(ij,k),ij=1,im*jm) nrgfdl=nrgfdl+1 if (kind(uvtr) == real_single) then zmin = uvtr(ismin (npints,uvtr(1,k ),1),k ) zmax = uvtr(ismax (npints,uvtr(1,k ),1),k ) else if (kind(uvtr) == real_double) then zmin = uvtr(idmin (npints,uvtr(1,k ),1),k ) zmax = uvtr(idmax (npints,uvtr(1,k ),1),k ) endif PRINT 400, nrgfdl, ZMIN, ZMAX enddo c v comp do k = 1,levs ko = levs-k+1 do ij = 1,im*jm uvtr(ij,k)=v(ij,ko) enddo enddo do k = 1,levs write(30) (uvtr(ij,k),ij=1,im*jm) nrgfdl=nrgfdl+1 if (kind(uvtr) == real_single) then zmin = uvtr(ismin (npints,uvtr(1,k ),1),k ) zmax = uvtr(ismax (npints,uvtr(1,k ),1),k ) else if (kind(uvtr) == real_double) then zmin = uvtr(idmin (npints,uvtr(1,k ),1),k ) zmax = uvtr(idmax (npints,uvtr(1,k ),1),k ) endif PRINT 400, nrgfdl, ZMIN, ZMAX enddo deallocate (u); deallocate(v) c Now read in spec hum & skip other tracers... c do k=1,levs*ntrac allocate (qs(im*jm,levs),stat=iqsa) if (iqsa /= 0) then print *,'!!! ERROR ALLOCATING specific humidity (qs) array' print *,'!!! in ss2gghur....' return endif do k=1,levs read(iosig) (s1(i,k),i=1,nc) enddo c s1 = s1_4byte call sptran(0,jcap,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, & s1,qs(in,1),qs(is,1),1) deallocate (s1); deallocate (s2) c Calculate dry temps from spec hum allocate (t(im*jm,levs),stat=ita) if (ita /= 0) then print *,'!!! ERROR ALLOCATING temperature ratio (t) array' print *,'!!! in ss2gghur....' return endif do k = 1,levs do ij = 1,im*jm t(ij,k) = tv(ij,k)/(1.+FV*qs(ij,k)) enddo enddo c Flip dry temp array and write it out.... do k = 1,levs ko=levs-k+1 do ij = 1,im*jm uvtr(ij,k)=t(ij,ko) enddo enddo do k = 1,levs write(30) (uvtr(ij,k),ij=1,im*jm) nrgfdl=nrgfdl+1 if (kind(uvtr) == real_single) then zmin = uvtr(ismin (npints,uvtr(1,k ),1),k ) zmax = uvtr(ismax (npints,uvtr(1,k ),1),k ) else if (kind(uvtr) == real_double) then zmin = uvtr(idmin (npints,uvtr(1,k ),1),k ) zmax = uvtr(idmax (npints,uvtr(1,k ),1),k ) endif PRINT 400, nrgfdl, ZMIN, ZMAX enddo deallocate (t) deallocate (tv) c Now calculate mixing ratio from specific humidity allocate (r(im*jm,levs),stat=ira) if (ira /= 0) then print *,'!!! ERROR ALLOCATING mixing ratio (r) array' print *,'!!! in ss2gghur....' return endif do k = 1,levs do ij = 1,im*jm r(ij,k) = qs(ij,k)/(1.-qs(ij,k)) enddo enddo c Flip mixing ratio array.... do k = 1,levs ko = levs-k+1 do ij = 1,im*jm uvtr(ij,k) = r(ij,ko) enddo enddo do k = 1,levs write(30) (uvtr(ij,k),ij=1,im*jm) nrgfdl=nrgfdl+1 if (kind(uvtr) == real_single) then zmin = uvtr(ismin (npints,uvtr(1,k ),1),k ) zmax = uvtr(ismax (npints,uvtr(1,k ),1),k ) else if (kind(uvtr) == real_double) then zmin = uvtr(idmin (npints,uvtr(1,k ),1),k ) zmax = uvtr(idmax (npints,uvtr(1,k ),1),k ) endif PRINT 400, nrgfdl, ZMIN, ZMAX enddo deallocate (r) deallocate (qs) deallocate (uvtr) c First, get sfc temp & land-sea mask from global c surface analysis file.... c call rdbges(iosfc,im*jm,gtst,glsm) call sfcio_srohdc (iosfc,'for11',head,data,iret) if (iret == 0) then gtst = data%tsea glsm = data%slmsk else print *,' ' print *,'ERROR reading sst & land mask from sfc file.' print *,'ERROR code = ',iret,' ....EXITING....' print *,' ' stop 94 endif c one level fields... sfc temp, land-seamask, wetness(dum),zstar,pstar write(30) gtst nrgfdl=nrgfdl+1 zmin = minval(gtst) zmax = maxval(gtst) PRINT 400, nrgfdl, ZMIN, ZMAX write(30) glsm nrgfdl=nrgfdl+1 zmin = minval(glsm) zmax = maxval(glsm) PRINT 400, nrgfdl, ZMIN, ZMAX write(30) glsm nrgfdl=nrgfdl+1 zmin = minval(glsm) zmax = maxval(glsm) PRINT 400, nrgfdl, ZMIN, ZMAX write(30) gz nrgfdl=nrgfdl+1 zmin = minval(gz) zmax = maxval(gz) PRINT 400, nrgfdl, ZMIN, ZMAX write(30) gps nrgfdl=nrgfdl+1 zmin = minval(gps) zmax = maxval(gps) PRINT 400, nrgfdl, ZMIN, ZMAX 400 FORMAT(1X,'GFDL RECORD NUMBER = ',I6,2X, a 'MIN = ',E12.4, 2X, 'MAX =', E12.4) c return end