SUBROUTINE AF_ATRB ( isdx, maxsc, istrb, ietrb, iret ) C************************************************************************ C* AF_ATRB * C* * C* This subroutine locates, decodes, and stores the turbulence data * C* from within an AIREP report. The report must have already been * C* broken up into "like-type" groups using subroutine UT_BKGP. * C* Output includes the indices of the "like-type" groups which contain * C* the start and the end of the turbulence data; these values are set * C* to IMISSD if the search for the data was unsuccessful. * C* * C* AF_ATRB ( ISDX, MAXSC, ISTRB, IETRB, IRET ) * C* * C* Input parameters: * C* ISDX INTEGER Index of "like-type" group with * C* which to begin search for data * C* MAXSC INTEGER Maximum number of "like-type" * C* groups to search following ISDX * C* * C* Output parameters: * C* RIVALS (IRNTRB) REAL Number of turbulence levels * C* RIVALS (IRDGOT) REAL Degree of turbulence * C* RIVALS (IRFQOT) REAL Frequency of turbulence * C* RIVALS (IRTPOT) REAL Type of turbulence * C* ISTRB INTEGER Index of "like-type" group which* C* contains start of data * C* IETRB INTEGER Index of "like-type" group which* C* contains end of data * C* IRET INTEGER Return code * C* 0 = normal return * C* * C** * C* Log: * C* J. Ator/NP12 09/96 * C* J. Ator/NP12 08/97 New interface format, style changes * C* D. Kidwell/NCEP 6/99 Changed turbulence code values * C* J. Ator/NCEP 08/99 Initialize dgot to RMISSD * C* D. Kidwell/NCEP 2/00 Added call to AF_ATBX * C* D. Kidwell/NCEP 5/00 Added special codes for NWA,JAL,ANA,JAZ * C* J. Wu/GSC 7/00 Moved INCLUDE 'ERMISS.FNC' before the * C* DATA statement * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'afcmn.cmn' C* CHARACTER airlin*3, tbcode (9)*5 LOGICAL code, tbtabl INCLUDE 'ERMISS.FNC' INCLUDE 'affnc.fnc' C* DATA tbcode / 'ZERO', 'ONE', 'TWO', 'THREE', 'FOUR', + 'FIVE', 'SIX', 'SEVEN', 'O' / C* C----------------------------------------------------------------------- C C* Initialize variables. C iret = 0 istrb = IMISSD ietrb = IMISSD dgot = RMISSD fqot = RMISSD tpot = RMISSD C C* Locate the turbulence data. C ii = isdx maxii = IEDX ( ii, maxsc, nflds ) code = .false. C DO WHILE ( ( ii .le. maxii ) .and. ( istrb .eq. IMISSD ) ) IF ( ( ( lensf ( ii ) .eq. 2 ) .and. + ( fields ( ii ) (1:2) .eq. 'TB' ) ) + .or. + ( ( lensf ( ii ) .ge. 4 ) .and. + ( ( fields ( ii ) (1:4) .eq. 'TURB' ) .or. + ( fields ( ii ) (1:4) .eq. 'TRBC' ) ) ) ) THEN C C* The start of the turbulence data has been found as C* a "like-type" group consisting of "TB", "TURB", or C* "TRBC". C istrb = ii C C* There may or may not be an additional "like-type" C* group consisting of "CODE" directly before the C* "like-type" group containing the alphabetic or C* numeric turbulence indicator. C IF ( ( ii + 1 ) .le. maxii ) THEN IF ( ( lensf ( ii + 1 ) .eq. 4 ) .and. + ( fields ( ii + 1 ) (1:4) .eq. 'CODE' ) ) THEN ietrb = ii + 2 code = .true. ELSE ietrb = ii + 1 END IF ELSE ietrb = ii END IF ELSE IF ( ( lensf ( ii ) .eq. 4 ) .and. + ( fields ( ii ) (1:4) .eq. 'CODE' ) ) THEN C C* The turbulence data has been found as a "like-type" C* group consisting of "CODE" followed by a "like-type" C* group containing the alphabetic or numeric turbulence C* indicator. C istrb = ii ietrb = ii + 1 code = .true. END IF ii = ii + 1 END DO C C* Was any turbulence data found?? C IF ( ( istrb .eq. IMISSD ) .or. ( ietrb .eq. IMISSD ) ) THEN RETURN END IF IF ( ietrb .gt. maxii ) ietrb = maxii C C* Decode the turbulence data. C airlin = civals ( icacid ) ( :3 ) tbtabl = .false. C C* First check to see if this is an AIREP from an airline which C* has its own turbulence code table. C IF ( ( airlin .eq. 'NWA' ) .or. ( airlin .eq. 'JAL' ) .or. + ( airlin .eq. 'ANA' ) .or. ( airlin .eq. 'JAZ' ) ) THEN IF ( itypsf ( ietrb ) .eq. NMR ) THEN CALL ST_INTG ( fields ( ietrb ) ( :lensf ( ietrb ) ), + idgot, ier ) IF ( ( ier .eq. 0 ) .and. ( idgot .ge. 0 ) .and. + ( idgot .le. 7 ) ) THEN tbtabl = .true. END IF ELSE IF ( itypsf ( ietrb ) .eq. ALPHA ) THEN CALL ST_FIND ( fields ( ietrb ) ( :lensf ( ietrb ) ), + tbcode, 9, ipos, ier ) IF ( ipos .gt. 0 ) THEN idgot = ipos - 1 IF ( idgot .eq. 8 ) idgot = 0 tbtabl = .true. END IF END IF END IF C C* Degree of turbulence values are stored in the interface format C* using the following code figures - C* 0 = NONE C* 2 = LIGHT C* 3 = LIGHT TO MODERATE C* 4 = MODERATE C* 5 = MODERATE TO SEVERE C* 6 = SEVERE C* 8 = EXTREME C IF ( tbtabl ) THEN C C* Convert the airline turbulence code values to their C* interface values. C IF ( idgot .eq. 1 ) THEN dgot = 2. fqot = 1. ELSE IF ( idgot .eq. 7 ) THEN dgot = 8. ELSE dgot = FLOAT ( idgot ) END IF ELSE C C* Decode the turbulence either as plain English or, if C* numeric, use WMO code table 0302. C IF ( itypsf ( ietrb ) .eq. ALPHA ) THEN CALL AF_TBID ( fields ( ietrb ) ( 1 : lensf ( ietrb ) ), + dgot, iertbd ) ELSE IF ( itypsf ( ietrb ) .eq. NMR ) THEN CALL ST_INTG ( fields ( ietrb ) ( 1 : lensf ( ietrb ) ), + idgot, ier ) IF ( ( ier .eq. 0 ) .and. ( idgot .ge. 0 ) .and. + ( idgot .le. 3 ) ) THEN dgot = FLOAT ( idgot * 2 ) code = .true. END IF END IF C IF ( .not. code ) THEN C C* There may be more turbulence data to decode. Check the C* surrounding syntax. C dgotin = dgot CALL AF_ATBX ( ietrb, 6, dgotin, dgot, fqot, tpot, + ier1 ) IF ( ERMISS ( dgot ) ) THEN IF ( ier1 .eq. 0 ) THEN fqotsv = fqot tpotsv = tpot END IF C C* No degree of turbulence data was found after the C* "TB", "TURB" or "TRBC" keyword. Look at the groups C* preceding the keyword. C CALL AF_ATBX ( ietrb - 5, 4, dgotin, dgot, fqot, + tpot, ier2 ) IF ( ( ier2 .lt. 0 ) .and. ( ier1 .eq. 0 ) ) THEN fqot = fqotsv tpot = tpotsv END IF END IF END IF END IF C IF ( ERMISS ( dgot ) .and. ERMISS ( fqot ) .and. + ERMISS ( tpot ) ) THEN ELSE C C* Store the turbulence data. C rivals ( irntrb ) = 1 rivals ( irdgot (1) ) = dgot rivals ( irfqot (1) ) = fqot rivals ( irtpot (1) ) = tpot END IF C* RETURN END