64 USE yomhook
,ONLY : lhook, dr_hook
65 USE parkind1
,ONLY : jprb
74 INTEGER,
INTENT(IN) :: kluout
75 INTEGER,
DIMENSION(:),
INTENT(INOUT) :: kcode
82 REAL,
DIMENSION(:),
INTENT(IN) :: px
83 REAL,
DIMENSION(:),
INTENT(IN) :: py
84 REAL,
DIMENSION(:,:),
INTENT(INOUT) :: pfield
85 INTEGER,
INTENT(OUT) :: krep
90 INTEGER,
PARAMETER :: nd = 2
98 INTEGER,
PARAMETER :: idatamax = 2000
101 INTEGER,
PARAMETER :: isdmax = 20
104 INTEGER,
PARAMETER :: immax = 3
106 REAL,
DIMENSION(2,ND) :: zxdom
107 REAL,
DIMENSION(:,:),
ALLOCATABLE :: zxdata
108 REAL,
DIMENSION(:),
ALLOCATABLE :: zdata
109 INTEGER,
DIMENSION(ISDMAX,ISDMAX) :: ndomdata
112 REAL,
DIMENSION(:,:),
ALLOCATABLE :: zxout
113 REAL,
DIMENSION(:),
ALLOCATABLE :: zvalout
120 INTEGER,
PARAMETER :: iorder = 2
121 INTEGER,
PARAMETER :: im = (iorder*(iorder+1))/2
129 REAL,
DIMENSION(ND,ND) :: zg
133 REAL,
DIMENSION(:,:,:),
ALLOCATABLE :: zc
134 REAL,
DIMENSION(IDATAMAX+3*IMMAX) :: zwe
137 REAL(KIND=JPRB) :: zhook_handle
143 IF (lhook) CALL dr_hook(
'INTERPOL_SPLINES',0,zhook_handle)
144 ifield=
SIZE(pfield,2)
159 ALLOCATE(zxdata(nd,idata))
160 ALLOCATE(zdata(idata))
162 zxdata(1,:)=pack(px(:),mask=(kcode(:)>0))
163 zxdata(2,:)=pack(py(:),mask=(kcode(:)>0))
168 zxdom(1,1)=minval(px(:),mask=kcode(:)>=0)
169 zxdom(2,1)=maxval(px(:),mask=kcode(:)>=0)
170 zxdom(1,2)=minval(py(:),mask=kcode(:)>=0)
171 zxdom(2,2)=maxval(py(:),mask=kcode(:)>=0)
177 ALLOCATE(zxout(nd,iout))
178 ALLOCATE(zvalout(iout))
180 zxout(1,:)=pack(px(:),mask=(kcode(:)==0))
181 zxout(2,:)=pack(py(:),mask=(kcode(:)==0))
198 isdi=max(1,min(int( sqrt( idata/100+1 -1.e-6 )),isdmax))
205 ndomdata(jsdi,jsdj)= count( (kcode(:)>0) .AND. &
206 ( ( px(:) >= zxdom(1,1) + (jsdi-1-0.5/(iinter-1))*(zxdom(2,1)-zxdom(1,1))/isdi) &
207 .AND. ( px(:) <= zxdom(1,1) + (jsdi +0.5/(iinter-1))*(zxdom(2,1)-zxdom(1,1))/isdi) &
208 .AND. ( py(:) >= zxdom(1,2) + (jsdj-1-0.5/(iinter-1))*(zxdom(2,2)-zxdom(1,2))/isdj) &
209 .AND. ( py(:) <= zxdom(1,2) + (jsdj +0.5/(iinter-1))*(zxdom(2,2)-zxdom(1,2))/isdj) ) &
213 IF ( (isdi<isdmax) .AND. (isdj<isdmax) .AND. any(ndomdata(1:isdi,1:isdj) > idatamax/2) )
THEN
221 IF ( any(ndomdata(1:isdi,1:isdj) > idatamax) )
THEN
222 WRITE(kluout,*)
'**********************************************************'
223 WRITE(kluout,*)
'* ERROR during data interpolation *'
224 WRITE(kluout,*)
'* interpolation by splines routines is impossible *'
225 WRITE(kluout,*)
'* please use an input data file with a better resolution *'
226 WRITE(kluout,*)
'**********************************************************'
227 CALL
abor1_sfx(
'INTERPOL_SPLINES: ERROR DURING DATA INTERPOLATION BY SPLINES')
230 WRITE(kluout,*)
'----------------------------------'
243 WRITE(kluout,*)
' domain sdi=',jsdi,
' sdj=',jsdj,
' : ', &
244 ndomdata(jsdi,jsdj),
' data points available'
252 IF (iverb>=7)
WRITE(kluout,*)
' splines computations:'
257 ALLOCATE(zc( idatamax+immax , isdi , isdj ))
265 zdata(:)=pack(pfield(:,jk),mask=(kcode(:)>0))
270 zminval = minval(zdata)
271 zmaxval = maxval(zdata)
273 IF ( abs(zmaxval - zminval) <= 1.e-10 * max(abs(zmaxval),abs(zminval)) )
THEN
276 zvalout(:)=maxval(zdata)
289 CALL
splb2c(iiorder,iim,zxdata,zg,zdata,zs2,zp,0,iopt,isdi,isdj,iinter,zxdom,zc,krep)
296 WRITE(kluout,*)
'Routine INTERPOL_SPLINES: error in SPLB2C, KREP=',krep
297 WRITE(kluout,*)
'The field is interpolated from 3 nearest points'
298 IF (
ALLOCATED(zxdata))
DEALLOCATE(zxdata)
299 IF (
ALLOCATED(zdata))
DEALLOCATE(zdata)
300 IF (
ALLOCATED(zc))
DEALLOCATE(zc)
301 IF (
ALLOCATED(zvalout))
DEALLOCATE(zvalout)
302 IF (
ALLOCATED(zxout))
DEALLOCATE(zxout)
303 IF (lhook) CALL dr_hook(
'INTERPOL_SPLINES',1,zhook_handle)
314 IF (iverb>=7)
WRITE(kluout,*)
' splines evaluations'
316 CALL
splb2e(iiorder,iim,isdi,isdj,zg,zc,zxout,zvalout)
326 DO jin=1,
SIZE(pfield,1)
327 IF (kcode(jin)/=0) cycle
329 pfield(jin,jk) = zvalout(jout)
330 pfield(jin,jk) = max(zminval, min(zmaxval,pfield(jin,jk)))
341 IF (
ALLOCATED(zxdata))
DEALLOCATE(zxdata)
342 IF (
ALLOCATED(zdata))
DEALLOCATE(zdata)
343 IF (
ALLOCATED(zc))
DEALLOCATE(zc)
344 IF (
ALLOCATED(zvalout))
DEALLOCATE(zvalout)
345 IF (
ALLOCATED(zxout))
DEALLOCATE(zxout)
346 IF (lhook) CALL dr_hook(
'INTERPOL_SPLINES',1,zhook_handle)
subroutine interpol_splines(KLUOUT, KCODE, PX, PY, PFIELD, KREP)
subroutine abor1_sfx(YTEXT)