1C Copyright 1981-2016 ECMWF. 2C 3C This software is licensed under the terms of the Apache Licence 4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. 5C 6C In applying this licence, ECMWF does not waive the privileges and immunities 7C granted to it by virtue of its status as an intergovernmental organisation 8C nor does it submit to any jurisdiction. 9C 10 11 INTEGER FUNCTION MKBITMP(KWE,KNS,ZSEC4,ZMISS) 12C 13C----> 14C**** MKBITMP 15C 16C Purpose 17C ------- 18C 19C Remove points using a bitmap. 20C 21C 22C Interface 23C --------- 24C 25C CALL MKBITMP(KWE,KNS,ZSEC4,ZMISS) 26C 27C Input 28C ----- 29C 30C KWE - Number of points west-east in input field. 31C KNS - Number of points north-south in input field. 32C ZSEC4 - GRIBEX section 4 values in the field. 33C ZMISS - Value to be used as the missing data value.. 34C 35C 36C Output 37C ------ 38C 39C ZSEC4 - GRIBEX section 4 values with the points marked as 40C 'missing' by the bitmap replaced by missing data values. 41C 42C Function returns 0 if all OK. 43C 44C 45C Method 46C ------ 47C 48C The field and bitmap are rectangular. 49C Use NOBITMP, the name of a file describing the bitmap. 50C 51C 52C Externals 53C --------- 54C 55C INTLOG - Log error message. 56C MAKEMAP - Build a bitmap from definition in a file. 57C GMAPBIT - Get the bit value from a given position in a bitmap. 58C JFREE - Frees dynamically allocated memory. 59C 60C 61C Author 62C ------ 63C 64C J.D.Chambers ECMWF April 2000. 65C 66C----< 67C 68 IMPLICIT NONE 69C 70C Subroutine arguments 71C 72 INTEGER KWE,KNS 73 REAL ZSEC4(*), ZMISS 74C 75C Parameters 76C 77 INTEGER JPROUTINE 78 PARAMETER ( JPROUTINE = 44000 ) 79C 80C Local variables 81C 82 INTEGER IRET,BITMAP,NROWS,NCOLS,NVALUE,NEXT,IROW,ICOL,NINDEX 83 INTEGER OLDROWS, OLDCOLS, LOOP 84 CHARACTER*256 OLDFILE 85 DATA OLDFILE/' '/, BITMAP/-1/ 86 SAVE BITMAP,OLDROWS,OLDCOLS,OLDFILE 87C 88C Externals 89C 90 INTEGER MAKEMAP, GMAPBIT, JINDEX 91 EXTERNAL MAKEMAP, GMAPBIT, JINDEX 92C 93#include "parim.h" 94#include "jparams.h" 95#include "nofld.common" 96C 97C -----------------------------------------------------------------| 98C* Section 1. Initialise 99C -----------------------------------------------------------------| 100C 101 100 CONTINUE 102C 103 MKBITMP = 0 104C 105C Only build bitmap if filename has changed since last time through 106C 107 NINDEX = JINDEX(NOBITMP) 108 IF( NINDEX.LT.1 ) THEN 109 CALL INTLOG(JP_WARN,'MKBITMP: No bitmap name given',JPQUIET) 110 CALL INTLOG(JP_WARN,'MKBITMP: BITMAP NOT APPLIED',JPQUIET) 111 MKBITMP = JPROUTINE + 1 112 GOTO 900 113 ENDIF 114C 115 IF( OLDFILE(1:NINDEX).NE.NOBITMP(1:NINDEX) ) THEN 116 OLDFILE(1:NINDEX) = NOBITMP(1:NINDEX) 117 IF( NDBG.NE.0 ) 118 X CALL INTLOG(JP_DEBUG, 119 X 'MKBITMP: New BITMAP: '//OLDFILE(1:NINDEX),JPQUIET) 120C 121 IF( BITMAP.NE.-1 ) CALL JFREE(BITMAP) 122C 123 IRET = MAKEMAP(NOBITMP,NROWS,NCOLS,BITMAP) 124 IF( IRET.NE.0 ) THEN 125 CALL INTLOG(JP_WARN,'MKBITMP: Failed to make bitmap',IRET) 126 CALL INTLOG(JP_WARN,'MKBITMP: BITMAP NOT APPLIED',JPQUIET) 127 DO LOOP = 1, 256 128 OLDFILE(LOOP:LOOP) = ' ' 129 ENDDO 130 MKBITMP = JPROUTINE + 2 131 GOTO 900 132 ENDIF 133 OLDROWS = NROWS 134 OLDCOLS = NCOLS 135 ELSE 136 NROWS = OLDROWS 137 NCOLS = OLDCOLS 138 ENDIF 139C 140 IF( (NROWS.NE.KNS).OR.(NCOLS.NE.KWE) ) THEN 141 CALL INTLOG(JP_WARN,'MKBITMP: Bitmap invalid for area',JPQUIET) 142 CALL INTLOG(JP_WARN,'MKBITMP: No. of subarea rows = ',KNS) 143 CALL INTLOG(JP_WARN,'MKBITMP: No. of subarea columns = ',KWE) 144 CALL INTLOG(JP_WARN,'MKBITMP: No. of bitmap rows = ',NROWS) 145 CALL INTLOG(JP_WARN,'MKBITMP: No. of bitmap columns = ',NCOLS) 146 CALL INTLOG(JP_WARN,'MKBITMP: BITMAP NOT APPLIED',JPQUIET) 147 MKBITMP = JPROUTINE + 3 148 GOTO 900 149 ENDIF 150C 151C -----------------------------------------------------------------| 152C* Section 2. Use bitmap to force missing values 153C -----------------------------------------------------------------| 154C 155 200 CONTINUE 156C 157 IF( NDBG.NE.0 ) 158 X CALL INTLOG(JP_DEBUG,'MKBITMP: BITMAP applied',JPQUIET) 159C 160 NEXT = 0 161 DO IROW = 1, KNS 162 DO ICOL = 1, KWE 163 NEXT = NEXT + 1 164 NVALUE = GMAPBIT(BITMAP,NCOLS,IROW,ICOL) 165 IF( NVALUE.EQ.0 ) ZSEC4(NEXT) = ZMISS 166 ENDDO 167 ENDDO 168C 169C -----------------------------------------------------------------| 170C* Section 9. Closedown. 171C -----------------------------------------------------------------| 172C 173 900 CONTINUE 174C 175 RETURN 176 END 177