178
179
183
187# ifdef DISTRIBUTE
189# endif
190# ifdef ZETA_ELLIPTIC
193# endif
194
195
196
197 integer, intent(in) :: ng, tile
198 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
199 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
200 integer, intent(in) :: Lbck, Linp
201
202# ifdef ASSUMED_SHAPE
203 real(r8), intent(in) :: f(LBi:,LBj:)
204 real(r8), intent(in) :: pm(LBi:,LBj:)
205 real(r8), intent(in) :: pn(LBi:,LBj:)
206# ifdef ZETA_ELLIPTIC
207 real(r8), intent(in) :: h(LBi:,LBj:)
208 real(r8), intent(in) :: pmon_u(LBi:,LBj:)
209 real(r8), intent(in) :: pnom_v(LBi:,LBj:)
210# endif
211# ifdef SOLVE3D
212 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
213 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
214 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
215# endif
216# ifdef MASKING
217 real(r8), intent(in) :: rmask(LBi:,LBj:)
218 real(r8), intent(in) :: umask(LBi:,LBj:)
219 real(r8), intent(in) :: vmask(LBi:,LBj:)
220# endif
221# ifdef SOLVE3D
222 real(r8), intent(in) :: alpha(LBi:,LBj:)
223 real(r8), intent(in) :: beta(LBi:,LBj:)
224 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
225 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
226 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
227 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
228# endif
229 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
230# ifdef SOLVE3D
231 real(r8), intent(out) :: ad_rho(LBi:,LBj:,:)
232# endif
233# ifdef ZETA_ELLIPTIC
234 real(r8), intent(in) :: bc_ak(:)
235 real(r8), intent(in) :: bc_bk(:)
236 real(r8), intent(in) :: zdf1(:)
237 real(r8), intent(in) :: zdf2(:)
238 real(r8), intent(in) :: zdf3(:)
239 real(r8), intent(inout) :: pc_r2d(LBi:,LBj:)
240 real(r8), intent(inout) :: r_r2d(LBi:,LBj:,:)
241 real(r8), intent(inout) :: br_r2d(LBi:,LBj:,:)
242 real(r8), intent(inout) :: p_r2d(LBi:,LBj:,:)
243 real(r8), intent(inout) :: bp_r2d(LBi:,LBj:,:)
244 real(r8), intent(inout) :: ad_rhs_r2d(LBi:,LBj:)
245 real(r8), intent(inout) :: ad_zeta_ref(LBi:,LBj:)
246# endif
247
248# else
249
250 real(r8), intent(in) :: f(LBi:UBi,LBj:UBj)
251 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
252 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
253# ifdef ZETA_ELLIPTIC
254 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
255 real(r8), intent(in) :: pmon_u(LBi:UBi,LBj:UBj)
256 real(r8), intent(in) :: pnom_v(LBi:UBi,LBj:UBj)
257# endif
258# ifdef SOLVE3D
259 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
260 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
261 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
262# endif
263# ifdef MASKING
264 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
265 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
266 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
267# endif
268# ifdef SOLVE3D
269 real(r8), intent(in) :: alpha(LBi:UBi,LBj:UBj)
270 real(r8), intent(in) :: beta(LBi:UBi,LBj:UBj)
271 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
272 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
273 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,2,N(ng))
274 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,2,N(ng))
275# endif
276 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
277# ifdef SOLVE3D
278 real(r8), intent(out) :: ad_rho(LBi:UBi,LBj:UBj,N(ng))
279# endif
280# ifdef ZETA_ELLIPTIC
281 real(r8), intent(in) :: bc_ak(Nbico(ng))
282 real(r8), intent(in) :: bc_bk(Nbico(ng))
283 real(r8), intent(in) :: zdf1(Nbico(ng))
284 real(r8), intent(in) :: zdf2(Nbico(ng))
285 real(r8), intent(in) :: zdf3(Nbico(ng))
286 real(r8), intent(inout) :: pc_r2d(LBi:UBi,LBj:UBj)
287 real(r8), intent(inout) :: r_r2d(LBi:UBi,LBj:UBj,Nbico(ng))
288 real(r8), intent(inout) :: br_r2d(LBi:UBi,LBj:UBj,Nbico(ng))
289 real(r8), intent(inout) :: p_r2d(LBi:UBi,LBj:UBj,Nbico(ng))
290 real(r8), intent(inout) :: bp_r2d(LBi:UBi,LBj:UBj,Nbico(ng))
291 real(r8), intent(inout) :: ad_rhs_r2d(LBi:UBi,LBj:UBj)
292 real(r8), intent(inout) :: ad_zeta_ref(LBi:UBi,LBj:UBj)
293# endif
294
295# endif
296
297
298
299 integer :: i, j, k, order
300
301 integer :: Norder = 2
302
303 real(r8) :: fac, fac1, fac2, fac3, gamma
304 real(r8) :: cff, cff1, cff2, cff3, cff4
305 real(r8) :: ad_cff, ad_cff1, ad_cff2, adfac, adfac1, adfac2
306 real(r8) :: dzdT, zphi, zphi1, zwbot, zwtop
307
308 real(r8), dimension(20) :: filter_coef = &
309 & (/ 2.500000E-1_r8, 6.250000E-2_r8, 1.562500E-2_r8, &
310 & 3.906250E-3_r8, 9.765625E-4_r8, 2.44140625E-4_r8, &
311 & 6.103515625E-5_r8, 1.5258789063E-5_r8, 3.814697E-6_r8, &
312 & 9.536743E-7_r8, 2.384186E-7_r8, 5.960464E-8_r8, &
313 & 1.490116E-8_r8, 3.725290E-9_r8, 9.313226E-10_r8, &
314 & 2.328306E-10_r8, 5.820766E-11_r8, 1.455192E-11_r8, &
315 & 3.637979E-12_r8, 9.094947E-13_r8 /)
316
317 real(r8), dimension(N(ng)) :: dSdT, dSdT_filter
318
319 real(r8), dimension(IminS:ImaxS) :: ad_phie
320 real(r8), dimension(IminS:ImaxS) :: ad_phix
321
322# ifdef SALINITY
323 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
324
325 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,0:N(ng)) :: dTdz
326 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,0:N(ng)) :: dSdz
327# endif
328 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,N(ng)) :: ad_gradP
329
330# ifdef ZETA_ELLIPTIC
331 real(r8), dimension(IminS:ImaxS,N(ng)) :: ad_phi
332
333 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_gradPx
334 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_gradPy
335 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_r2d_rhs
336# endif
337
338# include "set_bounds.h"
339
340
341
342
343
344 ad_cff=0.0_r8
345 ad_cff1=0.0_r8
346 ad_cff2=0.0_r8
347 DO i=imins,imaxs
348 ad_phie(i)=0.0_r8
349 ad_phix(i)=0.0_r8
350 END DO
352 DO j=lbj,ubj
353 DO i=lbi,ubi
354 ad_rho(i,j,k)=0.0_r8
355 END DO
356 END DO
357 DO j=jmins,jmaxs
358 DO i=imins,imaxs
359 ad_gradp(i,j,k)=0.0_r8
360 END DO
361 END DO
362 END DO
363# ifdef ZETA_ELLIPTIC
365 DO i=imins,imaxs
366 ad_phi(i,k)=0.0_r8
367 END DO
368 END DO
369 DO j=jmins,jmaxs
370 DO i=imins,imaxs
371 ad_gradpx(i,j)=0.0_r8
372 ad_gradpy(i,j)=0.0_r8
373 END DO
374 END DO
375# endif
376
377
378
379
380
381
383
384# ifdef DISTRIBUTE
385
386
387
388
389
390
392 & lbi, ubi, lbj, ubj, &
395 & ad_zeta(:,:,linp))
396
397# endif
399
400
401
402
404 & lbi, ubi, lbj, ubj, &
405 & ad_zeta(:,:,linp))
406 END IF
407# ifdef ZETA_ELLIPTIC
408
409
410
411
412 DO j=jstr,jend
413 DO i=istr,iend
414
415
416 ad_zeta_ref(i,j)=ad_zeta(i,j,linp)
417 END DO
418 END DO
419
420
421
422
423
424
425
426
427# ifdef MASKING
428
429# endif
430
431
432
433
435 & lbi, ubi, lbj, ubj, &
436 & imins, imaxs, jmins, jmaxs, &
437 & lbck, &
438 & h, pmon_u, pnom_v, pm, pn, &
439# ifdef MASKING
440 & umask, vmask, rmask, &
441# endif
442 & bc_ak, bc_bk, zdf1, zdf2, zdf3, &
443 & pc_r2d, r_r2d, br_r2d, p_r2d, bp_r2d, &
444 & ad_zeta_ref, ad_rhs_r2d)
445
446 DO j=jstr,jend
447 DO i=istr,iend
448
449
450 ad_zeta_ref(i,j)=0.0_r8
451 END DO
452 END DO
453
454# ifdef DISTRIBUTE
455
456
457
458
459
460
462 & lbi, ubi, lbj, ubj, &
465 & ad_rhs_r2d)
466# endif
467
468
469
470
472 & lbi, ubi, lbj, ubj, &
473 & ad_rhs_r2d)
474
475
476
477 DO j=jstr,jend
478 DO i=istr,iend
479# ifdef MASKING
480
481
482 ad_rhs_r2d(i,j)=ad_rhs_r2d(i,j)*rmask(i,j)
483# endif
484
485
486
487
488
489
490 adfac=-pm(i,j)*pn(i,j)*ad_rhs_r2d(i,j)
491 ad_gradpx(i ,j)=ad_gradpx(i ,j)-pmon_u(i ,j)*adfac
492 ad_gradpx(i+1,j)=ad_gradpx(i+1,j)+pmon_u(i+1,j)*adfac
493 ad_gradpy(i,j )=ad_gradpy(i,j )-pnom_v(i,j )*adfac
494 ad_gradpy(i,j+1)=ad_gradpy(i,j+1)+pnom_v(i,j+1)*adfac
495 ad_rhs_r2d(i,j)=0.0_r8
496 END DO
497 END DO
498
499
500
501
502
503
504
506 & imins, imaxs, jmins, jmaxs, &
507 & ad_gradpy)
508
509
510
511
513 & imins, imaxs, jmins, jmaxs, &
514 & ad_gradpx)
515
516# else
517
518
519
523 DO j=jstr,jend
524 DO i=istr,iend
525
526
527 ad_cff=ad_cff+ad_zeta(i,j,linp)
528# ifdef MASKING
529
530
531 ad_cff=ad_cff*rmask(i,j)
532# endif
533
534
535 ad_rho(i,j,k)=ad_rho(i,j,k)- &
536 & cff1*hz(i,j,k)*ad_cff
537 ad_cff=0.0_r8
538 END DO
539 END DO
540 END DO
541
542
543
544
545
546
547
548
551 DO j=jstr,jend
552 DO i=istr,iend
554 zwtop=abs(z_w(i,j,k ))
555 zwbot=abs(z_w(i,j,k-1))
557
558
559 ad_cff=ad_cff+ad_zeta(i,j,linp)
560# ifdef MASKING
561
562
563 ad_cff=ad_cff*rmask(i,j)
564# endif
565
566
567 ad_rho(i,j,k)=ad_rho(i,j,k)- &
568 & cff1*hz(i,j,k)*ad_cff
569 ad_cff=0.0_r8
572
573
574 ad_cff=ad_cff+ad_zeta(i,j,linp)
575# ifdef MASKING
576
577
578 ad_cff=ad_cff*rmask(i,j)
579# endif
580 zphi=abs(z_r(i,j,k))
583
584
585 ad_rho(i,j,k)=ad_rho(i,j,k)- &
586 & cff1*hz(i,j,k)*ad_cff
587 ad_cff=0.0_r8
588 ELSE
589 zphi1=abs(z_r(i,j,k+1))
591
592
593
594
595
597 adfac1=fac*adfac
598 ad_rho(i,j,k )=ad_rho(i,j,k )-adfac1
599 ad_rho(i,j,k+1)=ad_rho(i,j,k+1)-adfac+adfac1
600 ad_cff=0.0_r8
601 END IF
602 ELSE
603 IF (k.eq.1) THEN
604
605
606 ad_rho(i,j,k)=ad_rho(i,j,k)- &
607 & cff1*hz(i,j,k)*ad_cff
608 ad_cff=0.0_r8
609 ELSE
610 zphi1=abs(z_r(i,j,k-1))
612
613
614
615
616
618 adfac1=fac*adfac
619 ad_rho(i,j,k-1)=ad_rho(i,j,k-1)-adfac1
620 ad_rho(i,j,k )=ad_rho(i,j,k )-adfac+adfac1
621 ad_cff=0.0_r8
622 END IF
623 END IF
624 END IF
625 END DO
626 END DO
627 END DO
628 END IF
629# endif
630 END IF
631
632
633
634
635
636
637
639
640
641
642# ifdef DISTRIBUTE
643
644
645
646
647
648
650 & lbi, ubi, lbj, ubj, 1,
n(ng), &
653 & ad_u(:,:,:,linp), ad_v(:,:,:,linp))
654# endif
656
657
658
659
661 & lbi, ubi, lbj, ubj, 1,
n(ng), &
662 & ad_v(:,:,:,linp))
663
664
665
666
668 & lbi, ubi, lbj, ubj, 1,
n(ng), &
669 & ad_u(:,:,:,linp))
670 END IF
671
673 DO j=jstrv,jend
674 DO i=istr,iend
675# ifdef MASKING
676
677
678 ad_v(i,j,k,linp)=ad_v(i,j,k,linp)*vmask(i,j)
679# endif
680
681
682
683
684
685
686 adfac=0.25_r8*ad_v(i,j,k,linp)
687 ad_gradp(i ,j-1,k)=ad_gradp(i ,j-1,k)+adfac
688 ad_gradp(i+1,j-1,k)=ad_gradp(i+1,j-1,k)+adfac
689 ad_gradp(i ,j ,k)=ad_gradp(i ,j ,k)+adfac
690 ad_gradp(i+1,j ,k)=ad_gradp(i+1,j ,k)+adfac
691 END DO
692 END DO
693 END DO
694 END IF
695
696
697
698
700
701 fac2=0.0_r8
703
705 DO j=jstr-1,jend
706
707# ifdef ZETA_ELLIPTIC
708
709
710
711
714 DO i=istr,iend+1
715
716
717 ad_cff=ad_cff+ad_gradpx(i,j)
718# ifdef MASKING
719
720
721 ad_cff=ad_cff*umask(i,j)
722# endif
723
724
725 ad_phi(i,k)=ad_phi(i,k)+ &
726 & 0.5_r8*(hz(i-1,j,k)+hz(i,j,k))*ad_cff
727 ad_cff=0.0_r8
728 END DO
729 END DO
730 END IF
731# endif
732
733
734
735
736
737
739 DO i=istr,iend+1
740 cff1=1.0_r8/((z_r(i ,j,k+1)-z_r(i ,j,k))* &
741 & (z_r(i-1,j,k+1)-z_r(i-1,j,k)))
742 cff2=z_r(i ,j,k )-z_r(i-1,j,k )+ &
743 & z_r(i ,j,k+1)-z_r(i-1,j,k+1)
744 cff3=z_r(i ,j,k+1)-z_r(i ,j,k )- &
745 & z_r(i-1,j,k+1)+z_r(i-1,j,k )
746 gamma=0.125_r8*cff1*cff2*cff3
747
748 cff3=z_r(i,j,k+1)+z_r(i-1,j,k+1)- &
749 & z_r(i,j,k )-z_r(i-1,j,k )
750 cff4=(1.0_r8+gamma)*(z_r(i,j,k+1)-z_r(i-1,j,k+1))+ &
751 & (1.0_r8-gamma)*(z_r(i,j,k )-z_r(i-1,j,k ))
752
753# ifdef ZETA_ELLIPTIC
754
755
756 ad_phix(i)=ad_phix(i)+ad_phi(i,k)
757 ad_phi(i,k)=0.0_r8
758# endif
759
760
761
762 ad_phix(i)=ad_phix(i)+ &
763 & ad_gradp(i,j,k)*0.5_r8*(pm(i-1,j)+pm(i,j))/ &
764 & (f(i-1,j)+f(i,j))
765 ad_gradp(i,j,k)=0.0_r8
766
767
768
769 ad_cff1=fac3*cff3*ad_phix(i)
770 ad_cff2=-fac3*cff4*ad_phix(i)
771
772
773
774
775
776
777
778 adfac1=(1.0_r8+gamma)*ad_cff1
779 adfac2=(1.0_r8-gamma)*ad_cff1
780 ad_rho(i-1,j,k )=ad_rho(i-1,j,k )-adfac2-ad_cff2
781 ad_rho(i ,j,k )=ad_rho(i ,j,k )+adfac2-ad_cff2
782 ad_rho(i-1,j,k+1)=ad_rho(i-1,j,k+1)-adfac1+ad_cff2
783 ad_rho(i ,j,k+1)=ad_rho(i ,j,k+1)+adfac1+ad_cff2
784 ad_cff1=0.0_r8
785 ad_cff2=0.0_r8
786 END DO
787 END DO
788
789
790
791
792 DO i=istr,iend+1
793 cff1=z_w(i ,j,
n(ng))-z_r(i ,j,
n(ng))+ &
794 & z_w(i-1,j,
n(ng))-z_r(i-1,j,
n(ng))
795# ifdef ZETA_ELLIPTIC
796
797
798 ad_phix(i)=ad_phix(i)+ad_phi(i,
n(ng))
799 ad_phi(i,
n(ng))=0.0_r8
800# endif
801
802
803
804 ad_phix(i)=ad_phix(i)+ &
805 & ad_gradp(i,j,
n(ng))*0.5_r8*(pm(i-1,j)+pm(i,j))/ &
806 & (f(i-1,j)+f(i,j))
807 ad_gradp(i,j,
n(ng))=0.0_r8
808
809
810
811
812
813 adfac1=fac1*cff1*ad_phix(i)
814 adfac2=fac2*ad_phix(i)
815 ad_rho(i-1,j,
n(ng))=ad_rho(i-1,j,
n(ng))-adfac1
816 ad_rho(i ,j,
n(ng))=ad_rho(i ,j,
n(ng))+adfac1
817 ad_zeta(i-1,j,linp)=ad_zeta(i-1,j,linp)-adfac2
818 ad_zeta(i ,j,linp)=ad_zeta(i ,j,linp)+adfac2
819 ad_phix(i)=0.0_r8
820 END DO
821 END DO
822 END IF
823
824
825
828 DO j=jstr,jend
829 DO i=istru,iend
830# ifdef MASKING
831
832
833 ad_u(i,j,k,linp)=ad_u(i,j,k,linp)*umask(i,j)
834# endif
835
836
837
838
839
840
841 adfac=0.25_r8*ad_u(i,j,k,linp)
842 ad_gradp(i-1,j ,k)=ad_gradp(i-1,j ,k)-adfac
843 ad_gradp(i ,j ,k)=ad_gradp(i ,j ,k)-adfac
844 ad_gradp(i-1,j+1,k)=ad_gradp(i-1,j+1,k)-adfac
845 ad_gradp(i ,j+1,k)=ad_gradp(i ,j+1,k)-adfac
846 END DO
847 END DO
848 END DO
849 END IF
850
852 DO j=jstr,jend+1
853
854# ifdef ZETA_ELLIPTIC
855
856
857
858
861 DO i=istr-1,iend
862
863
864 ad_cff=ad_cff+ad_gradpy(i,j)
865# ifdef MASKING
866
867
868 ad_cff=ad_cff*vmask(i,j)
869# endif
870
871
872 ad_phi(i,k)=ad_phi(i,k)+ &
873 & 0.5_r8*(hz(i,j-1,k)+hz(i,j,k))*ad_cff
874 ad_cff=0.0_r8
875 END DO
876 END DO
877 END IF
878# endif
879
880
881
882
883
884
886 DO i=istr-1,iend
887 cff1=1.0_r8/((z_r(i,j ,k+1)-z_r(i,j ,k))* &
888 & (z_r(i,j-1,k+1)-z_r(i,j-1,k)))
889 cff2=z_r(i,j ,k )-z_r(i,j-1,k )+ &
890 & z_r(i,j ,k+1)-z_r(i,j-1,k+1)
891 cff3=z_r(i,j ,k+1)-z_r(i,j ,k )- &
892 & z_r(i,j-1,k+1)+z_r(i,j-1,k )
893 gamma=0.125_r8*cff1*cff2*cff3
894
895 cff3=z_r(i,j,k+1)+z_r(i,j-1,k+1)- &
896 & z_r(i,j,k )-z_r(i,j-1,k )
897 cff4=(1.0_r8+gamma)*(z_r(i,j,k+1)-z_r(i,j-1,k+1))+ &
898 & (1.0_r8-gamma)*(z_r(i,j,k )-z_r(i,j-1,k ))
899# ifdef ZETA_ELLIPTIC
900
901
902 ad_phie(i)=ad_phie(i)+ad_phi(i,k)
903 ad_phi(i,k)=0.0_r8
904# endif
905
906
907
908 ad_phie(i)=ad_phie(i)+ &
909 & ad_gradp(i,j,k)*0.5_r8*(pn(i,j-1)+pn(i,j))/ &
910 & (f(i,j-1)+f(i,j))
911 ad_gradp(i,j,k)=0.0_r8
912
913
914
915 ad_cff1=fac3*cff3*ad_phie(i)
916 ad_cff2=-fac3*cff4*ad_phie(i)
917
918
919
920
921
922
923
924 adfac1=(1.0_r8+gamma)*ad_cff1
925 adfac2=(1.0_r8-gamma)*ad_cff1
926 ad_rho(i,j-1,k )=ad_rho(i,j-1,k )-adfac2-ad_cff2
927 ad_rho(i,j ,k )=ad_rho(i,j ,k )+adfac2-ad_cff2
928 ad_rho(i,j-1,k+1)=ad_rho(i,j-1,k+1)-adfac1+ad_cff2
929 ad_rho(i,j ,k+1)=ad_rho(i,j ,k+1)+adfac1+ad_cff2
930 ad_cff1=0.0_r8
931 ad_cff2=0.0_r8
932 END DO
933 END DO
934
935
936
937
938 DO i=istr-1,iend
939 cff1=z_w(i,j ,
n(ng))-z_r(i,j ,
n(ng))+ &
940 & z_w(i,j-1,
n(ng))-z_r(i,j-1,
n(ng))
941# ifdef ZETA_ELLIPTIC
942
943
944 ad_phie(i)=ad_phie(i)+ad_phi(i,
n(ng))
945 ad_phi(i,
n(ng))=0.0_r8
946# endif
947
948
949
950 ad_phie(i)=ad_phie(i)+ &
951 & ad_gradp(i,j,
n(ng))*0.5_r8*(pn(i,j-1)+pn(i,j))/ &
952 & (f(i,j-1)+f(i,j))
953 ad_gradp(i,j,
n(ng))=0.0_r8
954
955
956
957
958
959 adfac1=fac1*cff1*ad_phie(i)
960 adfac2=fac2*ad_phie(i)
961 ad_rho(i,j-1,
n(ng))=ad_rho(i,j-1,
n(ng))-adfac1
962 ad_rho(i,j ,
n(ng))=ad_rho(i,j ,
n(ng))+adfac1
963 ad_zeta(i,j-1,linp)=ad_zeta(i,j-1,linp)-adfac2
964 ad_zeta(i,j ,linp)=ad_zeta(i,j ,linp)+adfac2
965 ad_phie(i)=0.0_r8
966 END DO
967 END DO
968
969# ifdef ZETA_ELLIPTIC
970
971
972
973 DO j=jmins,jmaxs
974 DO i=imins,imaxs
975
976
977 ad_gradpy(i,j)=0.0_r8
978
979
980 ad_gradpx(i,j)=0.0_r8
981 END DO
982 END DO
983# endif
984 END IF
985
986
987
988
989
990
991
993
994# ifdef DISTRIBUTE
995
996
997
998
999
1000
1002 & lbi, ubi, lbj, ubj, 1,
n(ng), &
1005 & ad_rho)
1006# endif
1008
1009
1010
1011
1013 & lbi, ubi, lbj, ubj, 1,
n(ng), &
1014 & ad_rho)
1015 END IF
1016
1017 DO j=jstrr,jendr
1019 DO i=istrr,iendr
1020# ifdef MASKING
1021
1022
1023 ad_rho(i,j,k)=ad_rho(i,j,k)*rmask(i,j)
1024# endif
1025# ifdef SALINITY
1026
1027
1028
1029 ad_t(i,j,k,linp,
isalt)=ad_t(i,j,k,linp,
isalt)+ &
1030 &
rho0*beta(i,j)*ad_rho(i,j,k)
1031# endif
1032
1033
1034 ad_t(i,j,k,linp,
itemp)=ad_t(i,j,k,linp,
itemp)- &
1035 &
rho0*alpha(i,j)*ad_rho(i,j,k)
1036 ad_rho(i,j,k)=0.0
1037 END DO
1038 END DO
1039 END DO
1040 END IF
1041
1042# ifdef SALINITY
1043
1044
1045
1046
1047
1049
1050# ifdef DISTRIBUTE
1051
1052
1053
1054
1055
1056
1058 & lbi, ubi, lbj, ubj, 1,
n(ng), &
1061 & ad_t(:,:,:,linp,
isalt))
1062# endif
1064
1065
1066
1067
1069 & lbi, ubi, lbj, ubj, 1,
n(ng), &
1070 & ad_t(:,:,:,linp,
isalt))
1071 END IF
1072
1073
1074
1075 DO j=jstrr,jendr
1076 DO i=istrr,iendr
1077 fc(i,0)=0.0_r8
1078 dtdz(i,j,0)=0.0_r8
1079 dsdz(i,j,0)=0.0_r8
1080 END DO
1082 DO i=istrr,iendr
1083 cff=1.0_r8/(2.0_r8*hz(i,j,k+1)+ &
1084 & hz(i,j,k)*(2.0_r8-fc(i,k-1)))
1085 fc(i,k)=cff*hz(i,j,k+1)
1086 dtdz(i,j,k)=cff*(6.0_r8*(t(i,j,k+1,lbck,
itemp)- &
1087 & t(i,j,k ,lbck,
itemp))- &
1088 & hz(i,j,k)*dtdz(i,j,k-1))
1089 dsdz(i,j,k)=cff*(6.0_r8*(t(i,j,k+1,lbck,
isalt)- &
1090 & t(i,j,k ,lbck,
isalt))- &
1091 & hz(i,j,k)*dsdz(i,j,k-1))
1092 END DO
1093 END DO
1094 DO i=istrr,iendr
1095 dtdz(i,j,
n(ng))=0.0_r8
1096 dsdz(i,j,
n(ng))=0.0_r8
1097 END DO
1099 DO i=istrr,iendr
1100 dtdz(i,j,k)=dtdz(i,j,k)-fc(i,k)*dtdz(i,j,k+1)
1101 dsdz(i,j,k)=dsdz(i,j,k)-fc(i,k)*dsdz(i,j,k+1)
1102 END DO
1103 END DO
1104 END DO
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119 DO j=jstrr,jendr
1120 DO i=istrr,iendr
1122 cff=0.5_r8*(dtdz(i,j,k-1)+dtdz(i,j,k))
1124 dzdt=0.0_r8
1125 ELSE
1126 dzdt=1.0_r8/cff
1127 END IF
1128 dsdt(k)=(0.5_r8*(dsdz(i,j,k-1)+ &
1129 & dsdz(i,j,k )))*dzdt
1130 END DO
1131
1132
1133
1134 DO order=1,norder/2
1135 IF (order.ne.norder/2) THEN
1136 dsdt_filter(1)=2.0_r8*(dsdt(1)-dsdt(2))
1137 dsdt_filter(
n(ng))=2.0_r8*(dsdt(
n(ng))-dsdt(
n(ng)-1))
1138 ELSE
1139 dsdt_filter(1)=0.0_r8
1140 dsdt_filter(
n(ng))=0.0_r8
1141 END IF
1143 dsdt_filter(k)=2.0_r8*dsdt(k)-dsdt(k-1)-dsdt(k+1)
1144 END DO
1146 dsdt(k)=dsdt(k)-filter_coef(norder/2)*dsdt_filter(k)
1147 END DO
1148 END DO
1149
1151 cff=(1.0_r8-exp(z_r(i,j,k)/
ml_depth(ng)))*dsdt(k)
1152# ifdef MASKING
1153
1154
1155 ad_t(i,j,k,linp,
isalt)=ad_t(i,j,k,linp,
isalt)*rmask(i,j)
1156# endif
1157
1158
1159
1160 ad_t(i,j,k,linp,
itemp)=ad_t(i,j,k,linp,
itemp)+ &
1161 & cff*ad_t(i,j,k,linp,
isalt)
1162 END DO
1163 END DO
1164 END DO
1165 END IF
1166# endif
1167
1168 RETURN
subroutine ad_exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
subroutine ad_exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
subroutine ad_exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
subroutine ad_exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
integer, dimension(:), allocatable istvar
integer, dimension(:), allocatable n
real(r8), dimension(:), allocatable ml_depth
real(r8), dimension(:), allocatable dtdz_min
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
logical, dimension(:), allocatable balance
real(r8), dimension(:), allocatable lnm_depth
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine, public u2d_bc(ng, tile, lbi, ubi, lbj, ubj, a)
subroutine, public v2d_bc(ng, tile, lbi, ubi, lbj, ubj, a)
subroutine, public ad_r2d_bc(ng, tile, lbi, ubi, lbj, ubj, ad_a)
subroutine, public ad_biconj_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, lbck, h, pmon_u, pnom_v, pm, pn, umask, vmask, rmask, bc_ak, bc_bk, zdf1, zdf2, zdf3, pc_r2d, r_r2d, br_r2d, p_r2d, bp_r2d, ad_r2d_ref, ad_rhs_r2d)