[7152] | 1 | PROGRAM fbsel |
---|
| 2 | !!--------------------------------------------------------------------- |
---|
| 3 | !! |
---|
| 4 | !! ** PROGRAM fbsel ** |
---|
| 5 | !! |
---|
| 6 | !! ** Purpose : Select or subsample observations |
---|
| 7 | !! |
---|
| 8 | !! ** Method : Use of utilities from obs_fbm. |
---|
| 9 | !! |
---|
| 10 | !! ** Action : |
---|
| 11 | !! |
---|
| 12 | !! Usage: |
---|
| 13 | !! fbsel.exe <input filename> <output filename> |
---|
| 14 | !! |
---|
| 15 | !! History : |
---|
| 16 | !! ! 2010 (K. Mogensen) Initial version |
---|
| 17 | !!---------------------------------------------------------------------- |
---|
| 18 | USE obs_fbm |
---|
| 19 | USE date_utils |
---|
| 20 | IMPLICIT NONE |
---|
| 21 | TYPE(obfbdata) :: fbdatain,fbdataout |
---|
| 22 | CHARACTER(len=256) :: filenamein,filenameout,filenametmp,cnameout |
---|
| 23 | #ifndef NOIARGCPROTO |
---|
| 24 | INTEGER,EXTERNAL :: iargc |
---|
| 25 | #endif |
---|
| 26 | INTEGER,PARAMETER :: maxtyp=1023 |
---|
| 27 | INTEGER,PARAMETER :: maxdates=20 |
---|
| 28 | INTEGER :: nqc,ntyp,ndates,ninidate(maxdates),nenddate(maxdates) |
---|
| 29 | LOGICAL :: lsplitqc,lsplittyp,lsplitstat |
---|
| 30 | INTEGER :: iqc,ityp,idate,istat |
---|
| 31 | REAL :: maxlat,minlat,maxlon,minlon |
---|
| 32 | CHARACTER(len=ilenwmo) :: cdwmo,cdwmobeg,cdwmoend |
---|
| 33 | CHARACTER(len=ilenwmo), DIMENSION(:), POINTER :: clstatids |
---|
| 34 | INTEGER :: nstat |
---|
| 35 | NAMELIST/namsel/nqc,ntyp,ndates,ninidate,nenddate,lsplitqc,lsplittyp, & |
---|
| 36 | & lsplitstat,maxlat,minlat,maxlon,minlon,cdwmo,& |
---|
| 37 | & cdwmobeg,cdwmoend |
---|
| 38 | |
---|
| 39 | IF (iargc()/=2) THEN |
---|
| 40 | WRITE(*,*)'Usage:' |
---|
| 41 | WRITE(*,*)'fbsel <input filename> <output filename>' |
---|
| 42 | CALL abort |
---|
| 43 | ENDIF |
---|
| 44 | |
---|
| 45 | CALL getarg(1,filenamein) |
---|
| 46 | CALL getarg(2,filenameout) |
---|
| 47 | |
---|
| 48 | nqc=-1 |
---|
| 49 | ntyp=-1 |
---|
| 50 | ndates=1 |
---|
| 51 | ninidate=19500101 |
---|
| 52 | nenddate=21000101 |
---|
| 53 | |
---|
| 54 | lsplitqc=.FALSE. |
---|
| 55 | lsplittyp=.FALSE. |
---|
| 56 | lsplitstat=.FALSE. |
---|
| 57 | cdwmo=REPEAT('X',ilenwmo) |
---|
| 58 | cdwmobeg=cdwmo |
---|
| 59 | cdwmoend=cdwmo |
---|
| 60 | maxlat=1e+38 |
---|
| 61 | minlat=-1e+38 |
---|
| 62 | maxlon=1e+38 |
---|
| 63 | minlon=-1e+38 |
---|
| 64 | OPEN(10,file='namsel.in') |
---|
| 65 | READ(10,namsel) |
---|
| 66 | CLOSE(10) |
---|
| 67 | IF (cdwmobeg==REPEAT('X',ilenwmo)) cdwmobeg=cdwmo |
---|
| 68 | IF (cdwmoend==REPEAT('X',ilenwmo)) cdwmoend=cdwmo |
---|
| 69 | WRITE(*,namsel) |
---|
| 70 | |
---|
| 71 | CALL init_obfbdata(fbdatain) |
---|
| 72 | CALL init_obfbdata(fbdataout) |
---|
| 73 | |
---|
| 74 | WRITE(*,*)'Reading file : ',TRIM(filenamein) |
---|
| 75 | CALL read_obfbdata(TRIM(filenamein),fbdatain) |
---|
| 76 | WRITE(*,*)'Number of observations before selection = ',fbdatain%nobs |
---|
| 77 | DO idate=1,ndates |
---|
| 78 | IF (ndates==1) THEN |
---|
| 79 | cnameout=filenameout |
---|
| 80 | ELSE |
---|
| 81 | WRITE(cnameout,'(I2.2,2A)')idate,'_',TRIM(filenameout) |
---|
| 82 | ENDIF |
---|
| 83 | IF (lsplitqc) THEN |
---|
| 84 | DO iqc=1,3 |
---|
| 85 | CALL fb_sel(fbdatain,fbdataout,iqc,ntyp, & |
---|
| 86 | & ninidate(idate),nenddate(idate), & |
---|
| 87 | & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) |
---|
| 88 | WRITE(filenametmp,'(A,I2.2,A,A)')'qc_',iqc,'_',TRIM(cnameout) |
---|
| 89 | IF (fbdataout%nobs>0) THEN |
---|
| 90 | WRITE(*,*)'QC selected = ',iqc |
---|
| 91 | WRITE(*,*)'Number of observations selected = ',fbdataout%nobs |
---|
| 92 | WRITE(*,*)'Writing file : ',TRIM(filenametmp) |
---|
| 93 | CALL write_obfbdata(TRIM(filenametmp),fbdataout) |
---|
| 94 | ENDIF |
---|
| 95 | CALL dealloc_obfbdata(fbdataout) |
---|
| 96 | ENDDO |
---|
| 97 | ELSEIF (lsplittyp) THEN |
---|
| 98 | DO ityp=0,maxtyp |
---|
| 99 | CALL fb_sel(fbdatain,fbdataout,nqc,ityp, & |
---|
| 100 | & ninidate(idate),nenddate(idate), & |
---|
| 101 | & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) |
---|
| 102 | WRITE(filenametmp,'(A,I4.4,A,A)')'typ_',ityp,'_',TRIM(cnameout) |
---|
| 103 | IF (fbdataout%nobs>0) THEN |
---|
| 104 | WRITE(*,*)'Type = ',ityp |
---|
| 105 | WRITE(*,*)'Number of observations selected = ',fbdataout%nobs |
---|
| 106 | WRITE(*,*)'Writing file : ',TRIM(filenametmp) |
---|
| 107 | CALL write_obfbdata(TRIM(filenametmp),fbdataout) |
---|
| 108 | ENDIF |
---|
| 109 | CALL dealloc_obfbdata(fbdataout) |
---|
| 110 | ENDDO |
---|
| 111 | ELSEIF (lsplitstat) THEN |
---|
| 112 | CALL fb_sel_uniqueids(fbdatain,clstatids,nstat) |
---|
| 113 | DO istat=1,nstat |
---|
| 114 | CALL fb_sel(fbdatain,fbdataout,nqc,ntyp, & |
---|
| 115 | & ninidate(idate),nenddate(idate), & |
---|
| 116 | & maxlat,minlat,maxlon,minlon,clstatids(istat),clstatids(istat)) |
---|
| 117 | WRITE(filenametmp,'(4A)')'statid_', & |
---|
| 118 | & TRIM(clstatids(istat)),'_',TRIM(cnameout) |
---|
| 119 | IF (fbdataout%nobs>0) THEN |
---|
| 120 | WRITE(*,*)'Station = ',clstatids(istat) |
---|
| 121 | WRITE(*,*)'Number of observations selected = ',fbdataout%nobs |
---|
| 122 | WRITE(*,*)'Writing file : ',TRIM(filenametmp) |
---|
| 123 | CALL write_obfbdata(TRIM(filenametmp),fbdataout) |
---|
| 124 | ENDIF |
---|
| 125 | CALL dealloc_obfbdata(fbdataout) |
---|
| 126 | ENDDO |
---|
| 127 | ELSE |
---|
| 128 | CALL fb_sel(fbdatain,fbdataout,nqc,ntyp, & |
---|
| 129 | & ninidate(idate),nenddate(idate), & |
---|
| 130 | & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) |
---|
| 131 | WRITE(*,*)'Number of observations selected = ',fbdataout%nobs |
---|
| 132 | WRITE(*,*)'Writing file : ',TRIM(cnameout) |
---|
| 133 | CALL write_obfbdata(TRIM(cnameout),fbdataout) |
---|
| 134 | CALL dealloc_obfbdata(fbdataout) |
---|
| 135 | ENDIF |
---|
| 136 | ENDDO |
---|
| 137 | |
---|
| 138 | CONTAINS |
---|
| 139 | |
---|
| 140 | SUBROUTINE fb_sel(fbdatain,fbdataout,nqc,ntyp,ninidate,nenddate,& |
---|
| 141 | & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) |
---|
| 142 | TYPE(obfbdata) :: fbdatain,fbdataout |
---|
| 143 | INTEGER :: nqc,ntyp,ninidate,nenddate |
---|
| 144 | REAL :: maxlat,minlat,maxlon,minlon |
---|
| 145 | CHARACTER(len=ilenwmo) :: cdwmobeg,cdwmoend |
---|
| 146 | INTEGER :: jobs |
---|
| 147 | INTEGER :: iqc,ityp |
---|
| 148 | LOGICAL :: llvalid(fbdatain%nobs) |
---|
| 149 | INTEGER :: iyea,imon,iday |
---|
| 150 | REAL(KIND=dp) :: zjini,zjend |
---|
| 151 | LOGICAL :: lcheckwmo |
---|
| 152 | |
---|
| 153 | lcheckwmo=(cdwmobeg/=REPEAT('X',ilenwmo)).OR.& |
---|
| 154 | & (cdwmoend/=REPEAT('X',ilenwmo)) |
---|
| 155 | iyea=ninidate/10000 |
---|
| 156 | imon=ninidate/100-iyea*100 |
---|
| 157 | iday=ninidate-iyea*10000-imon*100 |
---|
| 158 | CALL greg2jul(0,0,0,iday,imon,iyea,zjini) |
---|
| 159 | iyea=nenddate/10000 |
---|
| 160 | imon=nenddate/100-iyea*100 |
---|
| 161 | iday=nenddate-iyea*10000-imon*100 |
---|
| 162 | CALL greg2jul(0,0,0,iday,imon,iyea,zjend) |
---|
| 163 | DO jobs = 1, fbdatain%nobs |
---|
| 164 | llvalid(jobs)=.TRUE. |
---|
| 165 | IF (nqc/=-1) THEN |
---|
| 166 | CALL check_prof(fbdatain,jobs,iqc) |
---|
| 167 | llvalid(jobs)=(iqc==nqc).AND.llvalid(jobs) |
---|
| 168 | ENDIF |
---|
| 169 | IF (ntyp/=-1) THEN |
---|
| 170 | READ(fbdatain%cdtyp(jobs),'(I4)')ityp |
---|
| 171 | llvalid(jobs)=(ityp==ntyp).AND.llvalid(jobs) |
---|
| 172 | ENDIF |
---|
| 173 | IF (ninidate/=-1) THEN |
---|
| 174 | llvalid(jobs)=(fbdatain%ptim(jobs)>zjini).AND.llvalid(jobs) |
---|
| 175 | ENDIF |
---|
| 176 | IF (nenddate/=-1) THEN |
---|
| 177 | llvalid(jobs)=(fbdatain%ptim(jobs)<=zjend).AND.llvalid(jobs) |
---|
| 178 | ENDIF |
---|
| 179 | llvalid(jobs)=(fbdatain%pphi(jobs)<=maxlat).AND. & |
---|
| 180 | & (fbdatain%pphi(jobs)>=minlat).AND. & |
---|
| 181 | & (((fbdatain%plam(jobs)<=maxlon).AND. & |
---|
| 182 | & (fbdatain%plam(jobs)>=minlon)).OR. & |
---|
| 183 | & ((fbdatain%plam(jobs)+360<=maxlon).AND. & |
---|
| 184 | & (fbdatain%plam(jobs)+360>=minlon)).OR. & |
---|
| 185 | & ((fbdatain%plam(jobs)-360<=maxlon).AND. & |
---|
| 186 | & (fbdatain%plam(jobs)-360>=minlon))).AND.llvalid(jobs) |
---|
| 187 | IF (lcheckwmo) THEN |
---|
| 188 | llvalid(jobs)=LGE(TRIM(fbdatain%cdwmo(jobs)),TRIM(cdwmobeg)) & |
---|
| 189 | & .AND. LLE(TRIM(fbdatain%cdwmo(jobs)),TRIM(cdwmoend)) & |
---|
| 190 | & .AND. llvalid(jobs) |
---|
| 191 | ENDIF |
---|
| 192 | ! Add more checks here... |
---|
| 193 | ENDDO |
---|
| 194 | |
---|
| 195 | CALL subsamp_obfbdata(fbdatain,fbdataout,llvalid) |
---|
| 196 | |
---|
| 197 | END SUBROUTINE fb_sel |
---|
| 198 | |
---|
| 199 | SUBROUTINE fb_sel_uniqueids(fbdatain,clstatids,nstat) |
---|
| 200 | TYPE(obfbdata) :: fbdatain |
---|
| 201 | CHARACTER(len=ilenwmo), DIMENSION(:), POINTER :: clstatids |
---|
| 202 | INTEGER :: nstat |
---|
| 203 | INTEGER :: jobs,kobs |
---|
| 204 | LOGICAL, DIMENSION(fbdatain%nobs) :: lunique |
---|
| 205 | |
---|
| 206 | lunique(:)=.TRUE. |
---|
| 207 | DO jobs=1,fbdatain%nobs |
---|
| 208 | IF (.NOT.lunique(jobs)) CYCLE |
---|
| 209 | DO kobs=jobs+1,fbdatain%nobs |
---|
| 210 | IF (.NOT.lunique(kobs)) CYCLE |
---|
| 211 | IF (fbdatain%cdwmo(jobs)==fbdatain%cdwmo(kobs)) THEN |
---|
| 212 | lunique(kobs)=.FALSE. |
---|
| 213 | ENDIF |
---|
| 214 | ENDDO |
---|
| 215 | ENDDO |
---|
| 216 | nstat=COUNT(lunique) |
---|
| 217 | ALLOCATE(clstatids(nstat)) |
---|
| 218 | kobs=0 |
---|
| 219 | DO jobs=1,fbdatain%nobs |
---|
| 220 | IF (lunique(jobs)) THEN |
---|
| 221 | kobs=kobs+1 |
---|
| 222 | clstatids(kobs)=fbdatain%cdwmo(jobs) |
---|
| 223 | ENDIF |
---|
| 224 | ENDDO |
---|
| 225 | WRITE(*,*)'Unique station ids' |
---|
| 226 | DO jobs=1,nstat |
---|
| 227 | WRITE(*,'(I5,1X,A)')jobs,clstatids(jobs) |
---|
| 228 | ENDDO |
---|
| 229 | |
---|
| 230 | END SUBROUTINE fb_sel_uniqueids |
---|
| 231 | |
---|
| 232 | SUBROUTINE check_prof(fbdata,iobs,iqc) |
---|
| 233 | |
---|
| 234 | TYPE(obfbdata) :: fbdata |
---|
| 235 | INTEGER :: iobs,iqc |
---|
| 236 | INTEGER :: i,ivar |
---|
| 237 | |
---|
| 238 | LOGICAL :: lpart,lfull |
---|
| 239 | |
---|
| 240 | lpart=.false. |
---|
| 241 | lfull=.true. |
---|
| 242 | DO ivar=1,fbdata%nvar |
---|
| 243 | DO i=1,fbdata%nlev |
---|
| 244 | IF ((fbdata%ivlqc(i,iobs,ivar)>2).AND.& |
---|
| 245 | &(fbdata%ivlqc(i,iobs,ivar)<9)) lpart = .TRUE. |
---|
| 246 | IF (fbdata%ivlqc(i,iobs,ivar)<=2) lfull = .FALSE. |
---|
| 247 | ENDDO |
---|
| 248 | ENDDO |
---|
| 249 | |
---|
| 250 | IF(lfull) THEN |
---|
| 251 | iqc=3 |
---|
| 252 | ELSEIF (lpart) then |
---|
| 253 | iqc=2 |
---|
| 254 | ELSE |
---|
| 255 | iqc=1 |
---|
| 256 | ENDIF |
---|
| 257 | |
---|
| 258 | END SUBROUTINE check_prof |
---|
| 259 | |
---|
| 260 | END PROGRAM fbsel |
---|