ROMS_r215: /home/cholod/wd/peps/ROMS/romsagrif_r215/Roms_tools/Roms_Agrif/interp

00001 !
00002 ! $Id: interp_sta.F,v 1.1 2005/01/21 17:02:11 pmarches Exp $
00003 !
00004 #include "cppdefs.h"
00005 #ifdef STATIONS
00006       subroutine interp_r3d_sta (A, ifld, nfltmax, indx)
00007       implicit none
00008 # include "param.h"
00009 # include "grid.h"
00010 # include "sta.h"
00011 # include "scalars.h"
00012       integer ifld, nfltmax, indx(nfltmax)
00013       real A(GLOBAL_2D_ARRAY,N)
00014       integer id,iflt, i1,i2, j1,j2, k1,k2
00015       real p1,p2, q1,q2, r1,r2, cff1, cff2
00016 
00017       do id=1,nfltmax
00018         iflt=indx(id)
00019 
00020         k1=int(stainfo(istazgrd,iflt)+0.5)
00021         r2=stainfo(istazgrd,iflt)+0.5 - float(k1)
00022         r1=1.-r2
00023         k1=max(k1,   1)
00024         k2=min(k1+1, N)
00025 
00026         i1=int(stainfo(istaxgrd,iflt))
00027         i2=i1+1
00028         p2=stainfo(istaxgrd,iflt)-float(i1)
00029         p1=1.-p2
00030 
00031         j1=int(stainfo(istaygrd,iflt))
00032         j2=j1+1
00033         q2=stainfo(istaygrd,iflt)-float(j1)
00034         q1=1.0-q2
00035 
00036 #ifdef MASKING
00037         cff1=p1*q1*rmask(i1,j1)*(r1*A(i1,j1,k1)+r2*A(i1,j1,k2))
00038      &      +p2*q1*rmask(i2,j1)*(r1*A(i2,j1,k1)+r2*A(i2,j1,k2))
00039      &      +p1*q2*rmask(i1,j2)*(r1*A(i1,j2,k1)+r2*A(i1,j2,k2))
00040      &      +p2*q2*rmask(i2,j2)*(r1*A(i2,j2,k1)+r2*A(i2,j2,k2))
00041 
00042         cff2=q1*(p1*rmask(i1,j1) + p2*rmask(i2,j1))
00043      &      +q2*(p1*rmask(i1,j2) + p2*rmask(i2,j2))
00044 
00045         if (cff2.gt.0.) then
00046           stadata(ifld,iflt)=cff1/cff2
00047         else
00048           stadata(ifld,iflt)=0.0
00049         endif
00050 #else
00051         stadata(ifld,iflt)=p1*q1*(r1*A(i1,j1,k1)+r2*A(i1,j1,k2))
00052      &                       +p2*q1*(r1*A(i2,j1,k1)+r2*A(i2,j1,k2))
00053      &                       +p1*q2*(r1*A(i1,j2,k1)+r2*A(i1,j2,k2))
00054      &                       +p2*q2*(r1*A(i2,j2,k1)+r2*A(i2,j2,k2))
00055 #endif
00056       enddo
00057       return
00058       end
00059 
00060 
00061       subroutine interp_w3d_sta (A, ifld, nfltmax,indx)
00062       implicit none
00063 # include "param.h"
00064 # include "sta.h"
00065 # include "scalars.h"
00066       integer ifld, nfltmax, indx(nfltmax)
00067       real A(GLOBAL_2D_ARRAY,0:N)
00068       integer id,iflt, i1,i2, j1,j2, k1,k2
00069       real p1,p2, q1,q2, r1,r2
00070 
00071       do id=1,nfltmax
00072         iflt=indx(id)
00073 
00074         k1=int(stainfo(istazgrd,iflt))
00075         r2=stainfo(istazgrd,iflt) - float(k1)
00076         r1=1.-r2
00077         k1=max(k1,   0)
00078         k2=min(k1+1, N)
00079 
00080         i1=int(stainfo(istaxgrd,iflt))
00081         i2=i1+1
00082         p2=stainfo(istaxgrd,iflt)-float(i1)
00083         p1=1.-p2
00084 
00085         j1=int(stainfo(istaygrd,iflt))
00086         j2=j1+1
00087         q2=stainfo(istaygrd,iflt)-float(j1)
00088         q1=1.0-q2
00089 
00090         stadata(ifld,iflt)=p1*q1*(r1*A(i1,j1,k1)+r2*A(i1,j1,k2))
00091      &                       +p2*q1*(r1*A(i2,j1,k1)+r2*A(i2,j1,k2))
00092      &                       +p1*q2*(r1*A(i1,j2,k1)+r2*A(i1,j2,k2))
00093      &                       +p2*q2*(r1*A(i2,j2,k1)+r2*A(i2,j2,k2))
00094       enddo
00095       return
00096       end
00097 
00098 
00099       subroutine interp_r2d_sta (A, ifld, nfltmax, indx)
00100       implicit none
00101 # include "param.h"
00102 # include "sta.h"
00103 # include "scalars.h"
00104       integer ifld, nfltmax, indx(nfltmax)
00105       real A(GLOBAL_2D_ARRAY)
00106       integer id,iflt, i1,i2, j1,j2
00107       real p1,p2, q1,q2
00108 
00109       do id=1,nfltmax
00110         iflt=indx(id)
00111 
00112         i1=int(stainfo(istaxgrd,iflt))
00113         i2=i1+1
00114         p2=stainfo(istaxgrd,iflt)-float(i1)
00115         p1=1.-p2
00116 
00117         j1=int(stainfo(istaygrd,iflt))
00118         j2=j1+1
00119         q2=stainfo(istaygrd,iflt)-float(j1)
00120         q1=1.0-q2
00121 
00122         stadata(ifld,iflt)=q1*(p1*A(i1,j1) + p2*A(i2,j1))
00123      &                       +q2*(p1*A(i1,j2) + p2*A(i2,j2))
00124       enddo
00125       return
00126       end
00127 
00128       subroutine fill_sta_ini
00129       implicit none
00130 # include "param.h"
00131 # include "sta.h"
00132 # include "scalars.h"
00133 # include "nc_sta.h"
00134       integer iflt
00135       do iflt=1,nstas
00136          stadata(istadpt,iflt)=stainfo(istazgrd,iflt) ! Either the depth or the 
00137 
00138          if (wrtsta(indxstaGrd)) then
00139            stadata(istazgrd,iflt)=stainfo(istazgrd,iflt)! sigma level position is 
00140                                                  ! unavailaible
00141            stadata(istaxgrd,iflt)=stainfo(istaxgrd,iflt)! for initial storage 
00142            stadata(istaygrd,iflt)=stainfo(istaygrd,iflt)! for initial storage
00143          endif
00144       enddo
00145       return
00146       end
00147 
00148       subroutine interp_r2d_sta_ini (A, ifld)
00149       implicit none
00150 # include "param.h"
00151 # include "sta.h"
00152 # include "scalars.h"
00153       integer ifld
00154       real A(GLOBAL_2D_ARRAY)
00155       integer iflt, i1,i2, j1,j2
00156       real p1,p2, q1,q2
00157 
00158       do iflt=1,nstas
00159 
00160         i1=int(stainfo(istaxgrd,iflt))
00161         i2=i1+1
00162         p2=stainfo(istaxgrd,iflt)-float(i1)
00163         p1=1.-p2
00164 
00165         j1=int(stainfo(istaygrd,iflt))
00166         j2=j1+1
00167         q2=stainfo(istaygrd,iflt)-float(j1)
00168         q1=1.0-q2
00169 
00170         stadata(ifld,iflt)=q1*(p1*A(i1,j1) + p2*A(i2,j1))
00171      &                       +q2*(p1*A(i1,j2) + p2*A(i2,j2))
00172       enddo
00173       return
00174       end
00175 
00176 #else
00177       subroutine interp_sta_empty
00178       end
00179 #endif
/home/cholod/wd/peps/ROMS/romsagrif_r215/Roms_tools/Roms_Agrif/interp_sta.F
