betpar.f File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	betpar

Function/Subroutine Documentation

subroutine betpar

(

)

Definition at line 3 of file betpar.f.

Referenced by wocss().

C*********************************************************************
C
C  THIS SUBROUTINE ESTIMATES VARIABLE VALUES BETWEEN THE TOP AND 
C  BOTTOM LEVELS.   THE DEVIATION OF OBSERVED VALUE VAR FROM A LINEAR
C  PROFILE IS FIRST DETERMINED.  THEN THE DEVIATIONS AT EACH LEVEL 
C  ARE INTERPOLATED BY AN INVERSE DISTANCE TO A POWER (PWR) WEIGHTING 
C  SCHEME.  THE INTERPOLATED DEVIATIONS ARE USED TO CORRECT  THE 
C  CALCULATED PROFILES AT THE GRID POINTS.
C
C               --F  LUDWIG  6/2002
C
    include 'NGRIDS.PAR'
C       
        parameter(pwr=-2.0)
C
    include 'ANCHOR.CMM'
    include 'FLOWER.CMM'
    include 'LIMITS.CMM'
    include 'STALOC.CMM'
    include 'TSONDS.CMM'
C
    REAL varbl1(nsites),varbl2(nsites),varbl3(nsites)
    REAL xx(nsites),yy(nsites),atemp(nxgrd,nygrd)

    LOGICAL bysond(nxgrd,nygrd)
C
C  LOCAL VARIABLES:
C   VARBLJ(I)=  TEMPORARY STORAGE OF VALUES FROM SOUNDINGS TO 
C               BE USED FOR INTERPOLATION OF:
C                       POTENT. TEMP.           J=1
C                       POTENT. TEMP. LAPSE RATE    J=2
C                       ALTIMETER SETTING       J=3
C   XX,YY =     TEMPORARY STORAGE OF SOND SITE COORDINATES
C   ATEMP =     TEMPORARY STORAGE OF 2-D GRIDDED VALUES 
C   BYSOND =    FLAG FOR GRID PTS BY SONDS  
C
C  CHECK FOR ENOUGH SOND INFO
C
    IF (numtmp .LE. 0 .OR. nlvl .LE. 3) THEN
           WRITE(*,*) ' ONLY ',nlvl-1,' FLOW SURFACES'
           WRITE(*,*) ' ONLY ',numtmp,' T-SONDES'
           WRITE(*,*) 'CANNOT WORK '
           stop
        END IF
C
C  INTIALIZE BYSOND TO REFLECT GRID PTS BY TEMPERATURE SONDS THAT ARE TO
C  BE HELD FIXED.
C
    DO 22 ix=1,nxgrd
       DO 20 iy=1,nygrd
          DO 17 it=1,numtmp
         IF (ix.EQ.nint(xtmp(it)) .AND. 
     $                       iy.EQ.nint(ytmp(it))) THEN
                    bysond(ix,iy)=.true.
         ELSE
            bysond(ix,iy)=.false.
         END IF
17        CONTINUE
20     CONTINUE
22  CONTINUE
C
C  ESTIMATE POTENTIAL TEMP LAPSE RATE BY HORIZONTAL INTERPOLATION 
C  BETWEEN SOUNDINGS.
C
    DO 60 ix=1,ncol
       x0=float(ix)
       DO 55 iy=1,nrow
          y0=float(iy)
          DO 50 iz=2,nlvl
C
             DO 40 it=1,numtmp
               xx(it)=xtmp(it)
               yy(it)=ytmp(it)
                   varbl2(it)=ptlaps(it,iz)
40           CONTINUE
             CALL rinvmold(trpval,x0,y0,xx,yy,numtmp,varbl2)
             dthdzl(ix,iy,iz)=trpval
C
50        CONTINUE
55     CONTINUE
60  CONTINUE
C
C  ESTIMATE ALTIMETER SETTING ON FLOW GRID
C
    DO 200 ix=1,ncol
       x0=float(ix)
       DO 195 iy=1,nrow
          y0=float(iy)
          DO 190 iz=2,nlvl
             jkit=0
C
C  GET ALTIMETER SETTING AT SONDS
C
             DO 105 it=1,numtmp
C
C  USE ONLY NON-RASS SONDS
C
            IF (goodt(it)) THEN
                   jkit=jkit+1
               xx(jkit)=xtmp(it)
               yy(jkit)=ytmp(it)
                   varbl3(jkit)=altsig(it,iz)
             END IF
105      CONTINUE
             num3use=jkit
C
C  IF NO NON-RASS UPPER LEVEL PRESURE INFO, USE SFC VALUES
C
         IF (num3use.EQ.0) THEN
                DO 110 is=1,numnws
               IF (mnx .GT. 0 .AND. mnx .LE. nxgrd .AND. 
     $                         mny.GT.0 .AND. mny .LE. nygrd) THEN                  
                          IF (altim(is).GT.-9998.9) THEN
                             num3use=num3use+1
                 xx(num3use)=xg(is)
                 yy(num3use)=yg(is)
                 varbl3(num3use)=altim(is)
              END IF
               END IF
C              
110         CONTINUE
         END IF
C
C  CHECK FOR STATIONS ON GRID AT HEIGHTS NEAR THE FLOW SURFACE TO BE
C  ADDED TO THE LIST
C
             IF (num3use.GT.0) THEN
                CALL rinvmold(trpval,x0,y0,xx,yy,num3use,varbl3)
                setalt(ix,iy,iz)=trpval
            prmb(ix,iy,iz)=cvt2p(setalt(ix,iy,iz),
     $                             sfcht(ix,iy)+rhs(ix,iy,iz))
         ELSE
            prmb(ix,iy,iz)=0.0
         END IF
190       CONTINUE
195    CONTINUE
200 CONTINUE
C
C  ESTIMATE POTENTIAL TEMPERATURE ON FLOW GRID
C
    DO 300 ix=1,ncol
       x0=float(ix)
       DO 295 iy=1,nrow
          y0=float(iy)
          DO 290 iz=2,nlvl
C
C  GET POTENTIAL TEMPS AT SONDS
C
             DO 205 it=1,numtmp
            xx(it)=xtmp(it)
            yy(it)=ytmp(it)
                varbl1(it)=ptsigl(it,iz)
205      CONTINUE
             num1use=numtmp
C
             CALL rinvmold(trpval,x0,y0,xx,yy,num1use,varbl1)
             tmpkel(ix,iy,iz)=trpval
290       CONTINUE
295    CONTINUE
300 CONTINUE
C
C  NOW GET 1ST-GUESS TEMPERATURE AND ALTIMETER AT ANEMOMETER HEIGHT BY 
C  INTERPOATION OF SURFACE OBS.
C
    CALL vrsmoo (altim,atemp,numnws)
    DO 310 ix=1,ncol
      DO 310 iy=1,nrow
        setalt(ix,iy,1)=atemp(ix,iy)
        prmb(ix,iy,1)=cvt2p(setalt(ix,iy,1),sfcht(ix,iy)+z10)
310 CONTINUE
C
    CALL vrsmoo (tempc,atemp,numnws)
    DO 320 ix=1,ncol
      DO 320 iy=1,nrow
        tmpkel(ix,iy,1)=tpot(prmb(ix,iy,1),atemp(ix,iy))
320 CONTINUE
C
C  FINALLY GO BACK AND CHECK FOR BELOW GROUND SFCS, ALSO REPLACE
C  UPPER LEVEL SFC LEVEL INTERPOLATIONS (WHICH ARE UNRELIABLE) WITH
C  ESTIMATES FROM UPPER LEVEL SOND INTERPOLATION.
C
    DO 400 ix=1,ncol
       DO 395 iy=1,nrow 
          dthdzl(ix,iy,1)=dthdzl(ix,iy,levbot(ix,iy))
          DO 390 iz=2,levbot(ix,iy)
C
C  POINTS BELOW GROUND ARE SET TO ZERO
C
             IF (iz.LT.levbot(ix,iy)) THEN
            dthdzl(ix,iy,iz)=0.0
            setalt(ix,iy,iz)=0.0
                prmb(ix,iy,iz)=0.0
                tmpkel(ix,iy,iz)=0.0
C
C  IF FLOW SFC 2 IS NOT THE FIRST SURFACE ABOVE GROUND, ESTIMATE 
C  ANEMOMETER HEIGHT VALUES FROM THE FLOW SFC VALUES.
C           
         ELSE
            IF (iz.GT.2) THEN
               setalt(ix,iy,1)=setalt(ix,iy,iz)
                   prmb(ix,iy,1)=cvt2p(setalt(ix,iy,iz),
     $                                        sfcht(ix,iy)+z10)
                       tmpkel(ix,iy,1)=tmpkel(ix,iy,iz)-
     $                           (rhs(ix,iy,iz)-z10)*dthdzl(ix,iy,iz)
            END IF
         END IF
390       CONTINUE        
395    CONTINUE
400 CONTINUE
C
        RETURN
C

Here is the call graph for this function:

Here is the caller graph for this function: