/ncl_ncarg-6.0.0/ni/src/lib/nfpfort/wrf_user.f

# · FORTRAN Legacy · 771 lines · 500 code · 118 blank · 153 comment · 2 complexity · a8dc82dee49b753d38bd3f66a2e6cd53 MD5 · raw file

  1. C NCLFORTSTART
  2. SUBROUTINE DCOMPUTEPI(PI,PRESSURE,NX,NY,NZ)
  3. IMPLICIT NONE
  4. INTEGER NX,NY,NZ
  5. DOUBLE PRECISION PI(NX,NY,NZ)
  6. DOUBLE PRECISION PRESSURE(NX,NY,NZ)
  7. C NCLEND
  8. INTEGER I,J,K
  9. DOUBLE PRECISION P1000MB,R_D,CP
  10. PARAMETER (P1000MB=100000.D0,R_D=287.D0,CP=7.D0*R_D/2.D0)
  11. DO K = 1,NZ
  12. DO J = 1,NY
  13. DO I = 1,NX
  14. PI(I,J,K) = (PRESSURE(I,J,K)/P1000MB)** (R_D/CP)
  15. END DO
  16. END DO
  17. END DO
  18. END
  19. C NCLFORTSTART
  20. SUBROUTINE DCOMPUTETK(TK,PRESSURE,THETA,NX)
  21. IMPLICIT NONE
  22. INTEGER NX
  23. DOUBLE PRECISION PI
  24. DOUBLE PRECISION PRESSURE(NX)
  25. DOUBLE PRECISION THETA(NX)
  26. DOUBLE PRECISION TK(NX)
  27. C NCLEND
  28. INTEGER I
  29. DOUBLE PRECISION P1000MB,R_D,CP
  30. PARAMETER (P1000MB=100000.D0,R_D=287.D0,CP=7.D0*R_D/2.D0)
  31. DO I = 1,NX
  32. PI = (PRESSURE(I)/P1000MB)** (R_D/CP)
  33. TK(I) = PI*THETA(I)
  34. END DO
  35. END
  36. C NCLFORTSTART
  37. SUBROUTINE DINTERP3DZ(V3D,V2D,Z,LOC,NX,NY,NZ,VMSG)
  38. IMPLICIT NONE
  39. INTEGER NX,NY,NZ
  40. DOUBLE PRECISION V3D(NX,NY,NZ),V2D(NX,NY)
  41. DOUBLE PRECISION Z(NX,NY,NZ)
  42. DOUBLE PRECISION LOC
  43. DOUBLE PRECISION VMSG
  44. C NCLEND
  45. INTEGER I,J,KP,IP,IM
  46. LOGICAL INTERP
  47. DOUBLE PRECISION HEIGHT,W1,W2
  48. HEIGHT = LOC
  49. c does vertical coordinate increase or decrease with increasing k?
  50. c set offset appropriately
  51. IP = 0
  52. IM = 1
  53. IF (Z(1,1,1).GT.Z(1,1,NZ)) THEN
  54. IP = 1
  55. IM = 0
  56. END IF
  57. DO I = 1,NX
  58. DO J = 1,NY
  59. C Initialize to missing. Was initially hard-coded to -999999.
  60. V2D(I,J) = VMSG
  61. INTERP = .false.
  62. KP = NZ
  63. DO WHILE ((.NOT.INTERP) .AND. (KP.GE.2))
  64. IF (((Z(I,J,KP-IM).LE.HEIGHT).AND. (Z(I,J,
  65. + KP-IP).GT.HEIGHT))) THEN
  66. W2 = (HEIGHT-Z(I,J,KP-IM))/
  67. + (Z(I,J,KP-IP)-Z(I,J,KP-IM))
  68. W1 = 1.D0 - W2
  69. V2D(I,J) = W1*V3D(I,J,KP-IM) + W2*V3D(I,J,KP-IP)
  70. INTERP = .true.
  71. END IF
  72. KP = KP - 1
  73. END DO
  74. END DO
  75. END DO
  76. RETURN
  77. END
  78. C NCLFORTSTART
  79. SUBROUTINE DZSTAG(ZNEW,NX,NY,NZ,Z,NXZ,NYZ,NZZ,TERRAIN)
  80. IMPLICIT NONE
  81. INTEGER NX,NY,NZ,NXZ,NYZ,NZZ
  82. DOUBLE PRECISION ZNEW(NX,NY,NZ),Z(NXZ,NYZ,NZZ)
  83. DOUBLE PRECISION TERRAIN(NXZ,NYZ)
  84. C NCLEND
  85. INTEGER I,J,K,II,IM1,JJ,JM1
  86. c check for u, v, or w (x,y,or z) staggering
  87. c
  88. c for x and y stag, avg z to x, y, point
  89. c
  90. IF (NX.GT.NXZ) THEN
  91. DO K = 1,NZ
  92. DO J = 1,NY
  93. DO I = 1,NX
  94. II = MIN0(I,NXZ)
  95. IM1 = MAX0(I-1,1)
  96. ZNEW(I,J,K) = 0.5D0* (Z(II,J,K)+Z(IM1,J,K))
  97. END DO
  98. END DO
  99. END DO
  100. ELSE IF (NY.GT.NYZ) THEN
  101. DO K = 1,NZ
  102. DO J = 1,NY
  103. JJ = MIN0(J,NYZ)
  104. JM1 = MAX0(J-1,1)
  105. DO I = 1,NX
  106. ZNEW(I,J,K) = 0.5D0* (Z(I,JJ,K)+Z(I,JM1,K))
  107. END DO
  108. END DO
  109. END DO
  110. c
  111. c w (z) staggering
  112. c
  113. ELSE IF (NZ.GT.NZZ) THEN
  114. DO J = 1,NY
  115. DO I = 1,NX
  116. ZNEW(I,J,1) = TERRAIN(I,J)
  117. END DO
  118. END DO
  119. DO K = 2,NZ
  120. DO J = 1,NY
  121. DO I = 1,NX
  122. ZNEW(I,J,K) = ZNEW(I,J,K-1) +
  123. + 2.D0* (Z(I,J,K-1)-ZNEW(I,J,K-1))
  124. END DO
  125. END DO
  126. END DO
  127. END IF
  128. RETURN
  129. END
  130. C NCLFORTSTART
  131. SUBROUTINE DINTERP2DXY(V3D,V2D,XY,NX,NY,NZ,NXY)
  132. IMPLICIT NONE
  133. INTEGER NX,NY,NZ,NXY
  134. DOUBLE PRECISION V3D(NX,NY,NZ),V2D(NXY,NZ)
  135. DOUBLE PRECISION XY(2,NXY)
  136. C NCLEND
  137. INTEGER I,J,K,IJ
  138. DOUBLE PRECISION W11,W12,W21,W22,WX,WY
  139. DO IJ = 1,NXY
  140. I = MAX0(1,MIN0(NX-1,INT(XY(1,IJ)+1)))
  141. J = MAX0(1,MIN0(NY-1,INT(XY(2,IJ)+1)))
  142. WX = DBLE(I+1) - (XY(1,IJ)+1)
  143. WY = DBLE(J+1) - (XY(2,IJ)+1)
  144. W11 = WX*WY
  145. W21 = (1.D0-WX)*WY
  146. W12 = WX* (1.D0-WY)
  147. W22 = (1.D0-WX)* (1.D0-WY)
  148. DO K = 1,NZ
  149. V2D(IJ,K) = W11*V3D(I,J,K) + W21*V3D(I+1,J,K) +
  150. + W12*V3D(I,J+1,K) + W22*V3D(I+1,J+1,K)
  151. END DO
  152. END DO
  153. RETURN
  154. END
  155. C NCLFORTSTART
  156. SUBROUTINE DINTERP1D(V_IN,V_OUT,Z_IN,Z_OUT,NZ_IN,NZ_OUT,VMSG)
  157. IMPLICIT NONE
  158. INTEGER NZ_IN,NZ_OUT
  159. DOUBLE PRECISION V_IN(NZ_IN),Z_IN(NZ_IN)
  160. DOUBLE PRECISION V_OUT(NZ_OUT),Z_OUT(NZ_OUT)
  161. DOUBLE PRECISION VMSG
  162. C NCLEND
  163. INTEGER KP,K,IM,IP
  164. LOGICAL INTERP
  165. DOUBLE PRECISION HEIGHT,W1,W2
  166. c does vertical coordinate increase of decrease with increasing k?
  167. c set offset appropriately
  168. IP = 0
  169. IM = 1
  170. IF (Z_IN(1).GT.Z_IN(NZ_IN)) THEN
  171. IP = 1
  172. IM = 0
  173. END IF
  174. DO K = 1,NZ_OUT
  175. V_OUT(K) = VMSG
  176. INTERP = .false.
  177. KP = NZ_IN
  178. HEIGHT = Z_OUT(K)
  179. DO WHILE ((.NOT.INTERP) .AND. (KP.GE.2))
  180. IF (((Z_IN(KP-IM).LE.HEIGHT).AND.
  181. + (Z_IN(KP-IP).GT.HEIGHT))) THEN
  182. W2 = (HEIGHT-Z_IN(KP-IM))/ (Z_IN(KP-IP)-Z_IN(KP-IM))
  183. W1 = 1.D0 - W2
  184. V_OUT(K) = W1*V_IN(KP-IM) + W2*V_IN(KP-IP)
  185. INTERP = .true.
  186. END IF
  187. KP = KP - 1
  188. END DO
  189. END DO
  190. RETURN
  191. END
  192. c---------------------------------------------
  193. c Bill,
  194. c This routine assumes
  195. c index order is (i,j,k)
  196. c wrf staggering
  197. C
  198. c units: pressure (Pa), temperature(K), height (m), mixing ratio
  199. c (kg kg{-1}) availability of 3d p, t, and qv; 2d terrain; 1d
  200. c half-level zeta string
  201. c output units of SLP are Pa, but you should divide that by 100 for the
  202. c weather weenies.
  203. c virtual effects are included
  204. c
  205. C NCLFORTSTART
  206. SUBROUTINE DCOMPUTESEAPRS(NX,NY,NZ,Z,T,P,Q,SEA_LEVEL_PRESSURE,
  207. + T_SEA_LEVEL,T_SURF,LEVEL)
  208. IMPLICIT NONE
  209. c Estimate sea level pressure.
  210. INTEGER NX,NY,NZ
  211. DOUBLE PRECISION Z(NX,NY,NZ)
  212. DOUBLE PRECISION T(NX,NY,NZ),P(NX,NY,NZ),Q(NX,NY,NZ)
  213. c The output is the 2d sea level pressure.
  214. DOUBLE PRECISION SEA_LEVEL_PRESSURE(NX,NY)
  215. INTEGER LEVEL(NX,NY)
  216. DOUBLE PRECISION T_SURF(NX,NY),T_SEA_LEVEL(NX,NY)
  217. C NCLEND
  218. c Some required physical constants:
  219. DOUBLE PRECISION R,G,GAMMA
  220. PARAMETER (R=287.04D0,G=9.81D0,GAMMA=0.0065D0)
  221. c Specific constants for assumptions made in this routine:
  222. DOUBLE PRECISION TC,PCONST
  223. PARAMETER (TC=273.16D0+17.5D0,PCONST=10000)
  224. LOGICAL RIDICULOUS_MM5_TEST
  225. PARAMETER (RIDICULOUS_MM5_TEST=.TRUE.)
  226. c PARAMETER (ridiculous_mm5_test = .false.)
  227. c Local variables:
  228. INTEGER I,J,K
  229. INTEGER KLO,KHI
  230. DOUBLE PRECISION PLO,PHI,TLO,THI,ZLO,ZHI
  231. DOUBLE PRECISION P_AT_PCONST,T_AT_PCONST,Z_AT_PCONST
  232. DOUBLE PRECISION Z_HALF_LOWEST
  233. LOGICAL L1,L2,L3,FOUND
  234. C
  235. c Find least zeta level that is PCONST Pa above the surface. We
  236. c later use this level to extrapolate a surface pressure and
  237. c temperature, which is supposed to reduce the effect of the diurnal
  238. c heating cycle in the pressure field.
  239. DO J = 1,NY
  240. DO I = 1,NX
  241. LEVEL(I,J) = -1
  242. K = 1
  243. FOUND = .false.
  244. DO WHILE ((.NOT.FOUND) .AND. (K.LE.NZ))
  245. IF (P(I,J,K).LT.P(I,J,1)-PCONST) THEN
  246. LEVEL(I,J) = K
  247. FOUND = .true.
  248. END IF
  249. K = K + 1
  250. END DO
  251. IF (LEVEL(I,J).EQ.-1) THEN
  252. PRINT '(A,I4,A)','Troubles finding level ',
  253. + NINT(PCONST)/100,' above ground.'
  254. PRINT '(A,I4,A,I4,A)','Problems first occur at (',I,
  255. + ',',J,')'
  256. PRINT '(A,F6.1,A)','Surface pressure = ',P(I,J,1)/100,
  257. + ' hPa.'
  258. STOP 'Error_in_finding_100_hPa_up'
  259. END IF
  260. END DO
  261. END DO
  262. c Get temperature PCONST Pa above surface. Use this to extrapolate
  263. c the temperature at the surface and down to sea level.
  264. DO J = 1,NY
  265. DO I = 1,NX
  266. KLO = MAX(LEVEL(I,J)-1,1)
  267. KHI = MIN(KLO+1,NZ-1)
  268. IF (KLO.EQ.KHI) THEN
  269. PRINT '(A)','Trapping levels are weird.'
  270. PRINT '(A,I3,A,I3,A)','klo = ',KLO,', khi = ',KHI,
  271. + ': and they should not be equal.'
  272. STOP 'Error_trapping_levels'
  273. END IF
  274. PLO = P(I,J,KLO)
  275. PHI = P(I,J,KHI)
  276. TLO = T(I,J,KLO)* (1.D0+0.608D0*Q(I,J,KLO))
  277. THI = T(I,J,KHI)* (1.D0+0.608D0*Q(I,J,KHI))
  278. c zlo = zetahalf(klo)/ztop*(ztop-terrain(i,j))+terrain(i,j)
  279. c zhi = zetahalf(khi)/ztop*(ztop-terrain(i,j))+terrain(i,j)
  280. ZLO = Z(I,J,KLO)
  281. ZHI = Z(I,J,KHI)
  282. P_AT_PCONST = P(I,J,1) - PCONST
  283. T_AT_PCONST = THI - (THI-TLO)*LOG(P_AT_PCONST/PHI)*
  284. + LOG(PLO/PHI)
  285. Z_AT_PCONST = ZHI - (ZHI-ZLO)*LOG(P_AT_PCONST/PHI)*
  286. + LOG(PLO/PHI)
  287. T_SURF(I,J) = T_AT_PCONST* (P(I,J,1)/P_AT_PCONST)**
  288. + (GAMMA*R/G)
  289. T_SEA_LEVEL(I,J) = T_AT_PCONST + GAMMA*Z_AT_PCONST
  290. END DO
  291. END DO
  292. C
  293. c If we follow a traditional computation, there is a correction to the
  294. c sea level temperature if both the surface and sea level
  295. c temperatures are *too* hot.
  296. IF (RIDICULOUS_MM5_TEST) THEN
  297. DO J = 1,NY
  298. DO I = 1,NX
  299. L1 = T_SEA_LEVEL(I,J) .LT. TC
  300. L2 = T_SURF(I,J) .LE. TC
  301. L3 = .NOT. L1
  302. IF (L2 .AND. L3) THEN
  303. T_SEA_LEVEL(I,J) = TC
  304. ELSE
  305. T_SEA_LEVEL(I,J) = TC -
  306. + 0.005D0* (T_SURF(I,J)-TC)**2
  307. END IF
  308. END DO
  309. END DO
  310. END IF
  311. c The grand finale: ta da!
  312. DO J = 1,NY
  313. DO I = 1,NX
  314. c z_half_lowest=zetahalf(1)/ztop*(ztop-terrain(i,j))+terrain(i,j)
  315. Z_HALF_LOWEST = Z(I,J,1)
  316. C Convert to hPa in this step, by multiplying by 0.01. The original
  317. C Fortran routine didn't do this, but the NCL script that called it
  318. C did, so we moved it here.
  319. SEA_LEVEL_PRESSURE(I,J) = 0.01 * (P(I,J,1)*
  320. + EXP((2.D0*G*Z_HALF_LOWEST)/
  321. + (R* (T_SEA_LEVEL(I,J)+T_SURF(I,
  322. + J)))))
  323. END DO
  324. END DO
  325. c print *,'sea pres input at weird location i=20,j=1,k=1'
  326. c print *,'t=',t(20,1,1),t(20,2,1),t(20,3,1)
  327. c print *,'z=',z(20,1,1),z(20,2,1),z(20,3,1)
  328. c print *,'p=',p(20,1,1),p(20,2,1),p(20,3,1)
  329. c print *,'slp=',sea_level_pressure(20,1),
  330. c * sea_level_pressure(20,2),sea_level_pressure(20,3)
  331. END
  332. c---------------------------------------------------
  333. C
  334. C Double precision version. If you make a change here, you
  335. C must make the same change below to filter2d.
  336. C
  337. C NCLFORTSTART
  338. SUBROUTINE DFILTER2D(A,B,NX,NY,IT,MISSING)
  339. IMPLICIT NONE
  340. c Estimate sea level pressure.
  341. INTEGER NX,NY,IT
  342. DOUBLE PRECISION A(NX,NY),B(NX,NY),MISSING
  343. C NCLEND
  344. DOUBLE PRECISION COEF
  345. PARAMETER (COEF=0.25D0)
  346. INTEGER I,J,ITER
  347. DO ITER = 1,IT
  348. DO J = 1,NY
  349. DO I = 1,NX
  350. B(I,J) = A(I,J)
  351. END DO
  352. END DO
  353. DO J = 2,NY - 1
  354. DO I = 1,NX
  355. IF ( B(I,J-1).EQ.MISSING .OR. B(I,J).EQ.MISSING .OR.
  356. + B(I,J+1).EQ.MISSING ) THEN
  357. A(I,J) = A(I,J)
  358. ELSE
  359. A(I,J) = A(I,J) + COEF* (B(I,J-1)-2*B(I,J)+B(I,J+1))
  360. END IF
  361. END DO
  362. END DO
  363. DO J = 1,NY
  364. DO I = 2,NX - 1
  365. IF ( B(I-1,J).EQ.MISSING .OR. B(I,J).EQ.MISSING .OR.
  366. + B(I+1,J).EQ.MISSING ) THEN
  367. A(I,J) = A(I,J)
  368. ELSE
  369. A(I,J) = A(I,J) + COEF* (B(I-1,J)-2*B(I,J)+B(I+1,J))
  370. END IF
  371. END DO
  372. END DO
  373. c do j=1,ny
  374. c do i=1,nx
  375. c b(i,j) = a(i,j)
  376. c enddo
  377. c enddo
  378. c do j=2,ny-1
  379. c do i=1,nx
  380. c a(i,j) = a(i,j) - .99*coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
  381. c enddo
  382. c enddo
  383. c do j=1,ny
  384. c do i=2,nx-1
  385. c a(i,j) = a(i,j) - .99*coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
  386. c enddo
  387. c enddo
  388. END DO
  389. RETURN
  390. END
  391. C
  392. C Single precision version. If you make a change here, you
  393. C must make the same change above to dfilter2d.
  394. C
  395. C NCLFORTSTART
  396. SUBROUTINE filter2d( a, b, nx , ny , it, missing)
  397. IMPLICIT NONE
  398. c Estimate sea level pressure.
  399. INTEGER nx , ny, it
  400. REAL a(nx,ny),b(nx,ny), missing
  401. C NCLEND
  402. REAL coef
  403. parameter( coef = 0.25)
  404. INTEGER i,j,iter
  405. do iter=1, it
  406. do j=1,ny
  407. do i=1,nx
  408. b(i,j) = a(i,j)
  409. enddo
  410. enddo
  411. do j=2,ny-1
  412. do i=1,nx
  413. if ( b(i,j-1).eq.missing .or. b(i,j).eq.missing .or.
  414. + b(i,j+1).eq.missing ) then
  415. a(i,j) = a(i,j)
  416. else
  417. a(i,j) = a(i,j) + coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
  418. end if
  419. enddo
  420. enddo
  421. do j=1,ny
  422. do i=2,nx-1
  423. if ( b(i-1,j).eq.missing .or. b(i,j).eq.missing .or.
  424. + b(i+1,j).eq.missing ) then
  425. a(i,j) = a(i,j)
  426. else
  427. a(i,j) = a(i,j) + coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
  428. end if
  429. enddo
  430. enddo
  431. c do j=1,ny
  432. c do i=1,nx
  433. c b(i,j) = a(i,j)
  434. c enddo
  435. c enddo
  436. c do j=2,ny-1
  437. c do i=1,nx
  438. c a(i,j) = a(i,j) - .99*coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
  439. c enddo
  440. c enddo
  441. c do j=1,ny
  442. c do i=2,nx-1
  443. c a(i,j) = a(i,j) - .99*coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
  444. c enddo
  445. c enddo
  446. enddo
  447. return
  448. end
  449. c---------------------------------------------------------
  450. C NCLFORTSTART
  451. SUBROUTINE DCOMPUTERH(QV,P,T,RH,NX)
  452. IMPLICIT NONE
  453. INTEGER NX
  454. DOUBLE PRECISION QV(NX),P(NX),T(NX),RH(NX)
  455. C NCLEND
  456. DOUBLE PRECISION SVP1,SVP2,SVP3,SVPT0
  457. PARAMETER (SVP1=0.6112D0,SVP2=17.67D0,SVP3=29.65D0,SVPT0=273.15D0)
  458. INTEGER I
  459. DOUBLE PRECISION QVS,ES,PRESSURE,TEMPERATURE
  460. DOUBLE PRECISION EP_2,R_D,R_V
  461. PARAMETER (R_D=287.D0,R_V=461.6D0,EP_2=R_D/R_V)
  462. DOUBLE PRECISION EP_3
  463. PARAMETER (EP_3=0.622D0)
  464. DO I = 1,NX
  465. PRESSURE = P(I)
  466. TEMPERATURE = T(I)
  467. c es = 1000.*svp1*
  468. ES = 10.D0*SVP1*EXP(SVP2* (TEMPERATURE-SVPT0)/
  469. + (TEMPERATURE-SVP3))
  470. c qvs = ep_2*es/(pressure-es)
  471. QVS = EP_3*ES/ (0.01D0*PRESSURE- (1.D0-EP_3)*ES)
  472. c rh = 100*amax1(1., qv(i)/qvs)
  473. c rh(i) = 100.*qv(i)/qvs
  474. RH(I) = 100.D0*DMAX1(DMIN1(QV(I)/QVS,1.0D0),0.0D0)
  475. END DO
  476. RETURN
  477. END
  478. c----------------------------------------------
  479. C NCLFORTSTART
  480. SUBROUTINE DGETIJLATLONG(LAT_ARRAY,LONG_ARRAY,LAT,LONGITUDE,
  481. + II,JJ,NX,NY,IMSG)
  482. IMPLICIT NONE
  483. INTEGER NX,NY,II,JJ,IMSG
  484. DOUBLE PRECISION LAT_ARRAY(NX,NY),LONG_ARRAY(NX,NY)
  485. DOUBLE PRECISION LAT,LONGITUDE
  486. C NCLEND
  487. DOUBLE PRECISION LONGD,LATD
  488. INTEGER I,J
  489. DOUBLE PRECISION IR,JR
  490. DOUBLE PRECISION DIST_MIN,DIST
  491. C Init to missing. Was hard-coded to -999 initially.
  492. IR = IMSG
  493. JR = IMSG
  494. DIST_MIN = 1.D+20
  495. DO J = 1,NY
  496. DO I = 1,NX
  497. LATD = (LAT_ARRAY(I,J)-LAT)**2
  498. LONGD = (LONG_ARRAY(I,J)-LONGITUDE)**2
  499. C LONGD = DMIN1((LONG_ARRAY(I,J)-LONGITUDE)**2,
  500. C + (LONG_ARRAY(I,J)+LONGITUDE)**2)
  501. DIST = SQRT(LATD+LONGD)
  502. IF (DIST_MIN.GT.DIST) THEN
  503. DIST_MIN = DIST
  504. IR = DBLE(I)
  505. JR = DBLE(J)
  506. END IF
  507. END DO
  508. END DO
  509. C
  510. C The original version of this routine returned IR and JR. But, then
  511. C the NCL script that called this routine was converting IR and JR
  512. C to integer, so why not just return II and JJ?
  513. C
  514. C Also, I'm subtracing 1 here, because it will be returned to NCL
  515. C script which has 0-based indexing.
  516. C
  517. IF(IR.ne.IMSG.and.JR.ne.IMSG) then
  518. II = NINT(IR)-1
  519. JJ = NINT(JR)-1
  520. ELSE
  521. II = IMSG
  522. JJ = IMSG
  523. END IF
  524. c we will just return the nearest point at present
  525. RETURN
  526. END
  527. C NCLFORTSTART
  528. SUBROUTINE DCOMPUTEUVMET(U,V,UVMET,LONGCA,LONGCB,FLONG,FLAT,
  529. + CEN_LONG,CONE,RPD,NX,NY,NXP1,NYP1,
  530. + ISTAG,IS_MSG_VAL,UMSG,VMSG,UVMETMSG)
  531. IMPLICIT NONE
  532. C ISTAG should be 0 if the U,V grids are not staggered.
  533. C That is, NY = NYP1 and NX = NXP1.
  534. INTEGER NX,NY,NXP1,NYP1,ISTAG
  535. LOGICAL IS_MSG_VAL
  536. DOUBLE PRECISION U(NXP1,NY),V(NX,NYP1)
  537. DOUBLE PRECISION UVMET(NX,NY,2)
  538. DOUBLE PRECISION FLONG(NX,NY),FLAT(NX,NY)
  539. DOUBLE PRECISION LONGCB(NX,NY),LONGCA(NX,NY)
  540. DOUBLE PRECISION CEN_LONG,CONE,RPD
  541. DOUBLE PRECISION UMSG,VMSG,UVMETMSG
  542. C NCLEND
  543. INTEGER I,J
  544. DOUBLE PRECISION UK,VK
  545. c WRITE (6,FMT=*) ' in compute_uvmet ',NX,NY,NXP1,NYP1,ISTAG
  546. DO J = 1,NY
  547. DO I = 1,NX
  548. LONGCA(I,J) = FLONG(I,J) - CEN_LONG
  549. IF (LONGCA(I,J).GT.180.D0) THEN
  550. LONGCA(I,J) = LONGCA(I,J) - 360.D0
  551. END IF
  552. IF (LONGCA(I,J).LT.-180.D0) THEN
  553. LONGCA(I,J) = LONGCA(I,J) + 360.D0
  554. END IF
  555. IF (FLAT(I,J).LT.0.D0) THEN
  556. LONGCB(I,J) = -LONGCA(I,J)*CONE*RPD
  557. ELSE
  558. LONGCB(I,J) = LONGCA(I,J)*CONE*RPD
  559. END IF
  560. LONGCA(I,J) = COS(LONGCB(I,J))
  561. LONGCB(I,J) = SIN(LONGCB(I,J))
  562. END DO
  563. END DO
  564. c WRITE (6,FMT=*) ' computing velocities '
  565. DO J = 1,NY
  566. DO I = 1,NX
  567. IF (ISTAG.EQ.1) THEN
  568. IF (IS_MSG_VAL.AND.(U(I,J).EQ.UMSG.OR.
  569. + V(I,J).EQ.VMSG.OR.
  570. + U(I+1,J).EQ.UMSG.OR.
  571. + V(I,J+1).EQ.VMSG)) THEN
  572. UVMET(I,J,1) = UVMETMSG
  573. UVMET(I,J,2) = UVMETMSG
  574. ELSE
  575. UK = 0.5D0* (U(I,J)+U(I+1,J))
  576. VK = 0.5D0* (V(I,J)+V(I,J+1))
  577. UVMET(I,J,1) = VK*LONGCB(I,J) + UK*LONGCA(I,J)
  578. UVMET(I,J,2) = VK*LONGCA(I,J) - UK*LONGCB(I,J)
  579. END IF
  580. ELSE
  581. IF (IS_MSG_VAL.AND.(U(I,J).EQ.UMSG.OR.
  582. + V(I,J).EQ.VMSG)) THEN
  583. UVMET(I,J,1) = UVMETMSG
  584. UVMET(I,J,2) = UVMETMSG
  585. ELSE
  586. UK = U(I,J)
  587. VK = V(I,J)
  588. UVMET(I,J,1) = VK*LONGCB(I,J) + UK*LONGCA(I,J)
  589. UVMET(I,J,2) = VK*LONGCA(I,J) - UK*LONGCB(I,J)
  590. END IF
  591. END IF
  592. END DO
  593. END DO
  594. RETURN
  595. END
  596. C NCLFORTSTART
  597. C
  598. C This was originally a routine that took 2D input arrays. Since
  599. C the NCL C wrapper routine can handle multiple dimensions, it's
  600. C not necessary to have anything bigger than 1D here.
  601. C
  602. SUBROUTINE DCOMPUTETD(TD,PRESSURE,QV_IN,NX)
  603. IMPLICIT NONE
  604. INTEGER NX
  605. DOUBLE PRECISION PRESSURE(NX)
  606. DOUBLE PRECISION QV_IN(NX)
  607. DOUBLE PRECISION TD(NX)
  608. C NCLEND
  609. DOUBLE PRECISION QV,TDC
  610. INTEGER I
  611. DO I = 1,NX
  612. QV = DMAX1(QV_IN(I),0.D0)
  613. c vapor pressure
  614. TDC = QV*PRESSURE(I)/ (.622D0+QV)
  615. c avoid problems near zero
  616. TDC = DMAX1(TDC,0.001D0)
  617. TD(I) = (243.5D0*LOG(TDC)-440.8D0)/ (19.48D0-LOG(TDC))
  618. END DO
  619. RETURN
  620. END
  621. C NCLFORTSTART
  622. SUBROUTINE DCOMPUTEICLW(ICLW,PRESSURE,QC_IN,NX,NY,NZ)
  623. IMPLICIT NONE
  624. INTEGER NX,NY,NZ
  625. DOUBLE PRECISION PRESSURE(NX,NY,NZ)
  626. DOUBLE PRECISION QC_IN(NX,NY,NZ)
  627. DOUBLE PRECISION ICLW(NX,NY)
  628. DOUBLE PRECISION QCLW,DP,GG
  629. C NCLEND
  630. INTEGER I,J,K
  631. GG = 1000.D0/9.8D0
  632. DO J = 1,NY
  633. DO I = 1,NX
  634. ICLW(I,J) = 0.D0
  635. END DO
  636. END DO
  637. DO J = 3,NY - 2
  638. DO I = 3,NX - 2
  639. DO K = 1,NZ
  640. QCLW = DMAX1(QC_IN(I,J,K),0.D0)
  641. IF (K.EQ.1) THEN
  642. DP = (PRESSURE(I,J,K-1)-PRESSURE(I,J,K))
  643. ELSE IF (K.EQ.NZ) THEN
  644. DP = (PRESSURE(I,J,K)-PRESSURE(I,J,K+1))
  645. ELSE
  646. DP = (PRESSURE(I,J,K-1)-PRESSURE(I,J,K+1))/2.D0
  647. END IF
  648. ICLW(I,J) = ICLW(I,J) + QCLW*DP*GG
  649. END DO
  650. END DO
  651. END DO
  652. RETURN
  653. END