SUBROUTINE CLAPSE(KFILDO,NAREA,TELL,TELH,ATEL,BTEL,ISTOP,IER) C C JUNE 2015 GLAHN MDL C OCTOBER 2020 GHIRARDELLI CORRECTED TYPO NREA TO NAREA C C PURPOSE C TO FIND THE LINEAR LINE CONSTANT AND COEFFICIENT FOR C COMBINING TWO LAPSE RATES AS A FUNCTION OF THE C ELEVATION DIFFERENCE. IT IS SET UP SO THAT THEY C COULD BE DIFFERENT FOR THE FOUR ANALYSIS AREAS, BUT C ALL AREAS ARE CURRENTLY THE SAME. C C THIS WAS DEVELOPED PRIMARILY FOR CONUS TEMP AND TD. C THE GOAL IS TO USE PRIMARILY THE SURFACE BASED LAPSE C WHEN THE ELEVATION DISTANCE BETWEEN THE DATUM C AND THE GRIDPINT IS SMALL AND PRIMARILLY THE SURFACE C AND UPPER AIR BASED LAPSE WHEN THE ELEVATION DISTANCE C BETWEEN THE DATUM AND THE GRIDPOINT IS LARGE. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C NAREA = THE AREA OF THE ANALYSIS: C 1 = CONUS C 2 = ALASKA C 3 = HAWAII C 4 = PUERTO RICO C (INPUT) C TELL = LOWER THRESHOLD FOR WT. (OUTPUT) C TELH = HIGHER THRESHOLD FOR WT. (OUTPUT) C ATEL = CONSTANT FOR THE LINE. (OUTPUT) C BTEL = COEFFICIENT FOR THE LINE. (OUTPUT) C ISTOP = INCREMENTED IF THERE IS AN ERROR. C (INPUT/OUTPUT) C IER = STATUS RETURN. (OUTPUT) C 0 = GOOD RETURN. C 777 = NAREA IS INCORRECT. C TWOPT(I,J,L) = TWO POINTS (J,L) THROUGH WHICH THE LINE MUST C PASS, FOR EACH OF 4 AREAS (I=4). THE X VALUES C ARE METERS AND THE Y VALUES FRACTION. C (INTERNAL) C THRESH(I,J) = THE LOWER THRESHOLD (J=1) AND HIGHER C THRESHOLD (J=2) FOR THE WEIGHT OF XLAPSE( ) C COMPUTED FOR SURFACE DATA FOR 4 AREAS (I=1,4). C THIS MIGHT BE 0 AND 1, BUT COULD BE SOMETHING C ELSE LIKE .2 AND .9. (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES CALLED C NONE. C DIMENSION TWOPT(4,2,2),THRESH(4,2) C DATA TWOPT/150.,150.,150.,150.,1500.,1500.,1500.,1500., 1 0., 0., 0., 0., 1., 1., 1., 1./ DATA THRESH/150.,150.,150.,150.,1500.,1500.,1500.,1500./ C CALL TIMPR(KFILDO,KFILDO,'START CLAPSE ') C IER=0 C IF(NAREA.LT.1.OR.NAREA.GT.4)THEN WRITE(KFILDO,110)NAREA 110 FORMAT(/' ****NAREA IN CLAPSE =',I4,' NOT 1 TO 4 INCLUSIVE.') IER=777 ISTOP=ISTOP+1 GO TO 200 ENDIF C C CALCULATE SLOPE BTEL. C D WRITE(KFILDO,120)NAREA,TWOPT(NAREA,1,2),TWOPT(NAREA,1,1), D 1 TWOPT(NAREA,2,2),TWOPT(NAREA,2,1) D120 FORMAT(/' IN CLAPSE AT 120',I4,4F10.2) C BTEL=(TWOPT(NAREA,2,2)-TWOPT(NAREA,1,2))/ 1 (TWOPT(NAREA,2,1)-TWOPT(NAREA,1,1)) C C CALCULATE CONSTANT ATEL. C ATEL=-BTEL*TWOPT(NAREA,1,1)+TWOPT(NAREA,1,2) C C SET LOWER AND UPPER THRESHOLDS FOR WT. C TELL=THRESH(NAREA,1) TELH=THRESH(NAREA,2) C D WRITE(KFILDO,130)NAREA,TELL,TELH,ATEL,BTEL D130 FORMAT(/' IN CLAPSE--NAREA,TELL,TELH,ATEL,BTEL',I4,7F11.5) C 200 CONTINUE C CALL TIMPR(KFILDO,KFILDO,'END CLAPSE ') C RETURN END