3414
3415
3416
3417
3418 integer, intent(in) :: ng, tile
3419 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
3420 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
3421 integer, intent(in) :: nstp, nnew, ifac
3422
3423# ifdef ASSUMED_SHAPE
3424 real(r8), intent(in) :: pm(LBi:,LBj:)
3425 real(r8), intent(in) :: om_p(LBi:,LBj:)
3426 real(r8), intent(in) :: om_r(LBi:,LBj:)
3427 real(r8), intent(in) :: om_u(LBi:,LBj:)
3428 real(r8), intent(in) :: om_v(LBi:,LBj:)
3429 real(r8), intent(in) :: pn(LBi:,LBj:)
3430 real(r8), intent(in) :: on_p(LBi:,LBj:)
3431 real(r8), intent(in) :: on_r(LBi:,LBj:)
3432 real(r8), intent(in) :: on_u(LBi:,LBj:)
3433 real(r8), intent(in) :: on_v(LBi:,LBj:)
3434 real(r8), intent(in) :: pmon_p(LBi:,LBj:)
3435 real(r8), intent(in) :: pmon_r(LBi:,LBj:)
3436 real(r8), intent(in) :: pmon_u(LBi:,LBj:)
3437 real(r8), intent(in) :: pnom_p(LBi:,LBj:)
3438 real(r8), intent(in) :: pnom_r(LBi:,LBj:)
3439 real(r8), intent(in) :: pnom_v(LBi:,LBj:)
3440# ifdef MASKING
3441 real(r8), intent(in) :: pmask(LBi:,LBj:)
3442 real(r8), intent(in) :: rmask(LBi:,LBj:)
3443 real(r8), intent(in) :: umask(LBi:,LBj:)
3444 real(r8), intent(in) :: vmask(LBi:,LBj:)
3445# endif
3446 real(r8), intent(in) :: Kh(LBi:,LBj:)
3447# ifdef SOLVE3D
3448 real(r8), intent(in) :: Kv(LBi:,LBj:,0:)
3449# ifdef ICESHELF
3450 real(r8), intent(in) :: zice(LBi:,LBj:)
3451# endif
3452# if defined SEDIMENT && defined SED_MORPH
3453 real(r8), intent(in):: bed_thick(LBi:,LBj:,:)
3454# endif
3455 real(r8), intent(inout) :: h(LBi:,LBj:)
3456# endif
3457# ifdef ADJUST_BOUNDARY
3458# ifdef SOLVE3D
3459 real(r8), intent(out) :: VnormRobc(LBij:,:,:,:)
3460 real(r8), intent(out) :: VnormUobc(LBij:,:,:)
3461 real(r8), intent(out) :: VnormVobc(LBij:,:,:)
3462# endif
3463 real(r8), intent(out) :: HnormRobc(LBij:,:)
3464 real(r8), intent(out) :: HnormUobc(LBij:,:)
3465 real(r8), intent(out) :: HnormVobc(LBij:,:)
3466# endif
3467# ifdef ADJUST_WSTRESS
3468 real(r8), intent(out) :: HnormSUS(LBi:,LBj:)
3469 real(r8), intent(out) :: HnormSVS(LBi:,LBj:)
3470# endif
3471# if defined ADJUST_STFLUX && defined SOLVE3D
3472 real(r8), intent(out) :: HnormSTF(LBi:,LBj:,:)
3473# endif
3474# ifdef SOLVE3D
3475 real(r8), intent(out) :: VnormR(LBi:,LBj:,:,:,:)
3476 real(r8), intent(out) :: VnormU(LBi:,LBj:,:,:)
3477 real(r8), intent(out) :: VnormV(LBi:,LBj:,:,:)
3478# endif
3479 real(r8), intent(out) :: HnormR(LBi:,LBj:,:)
3480 real(r8), intent(out) :: HnormU(LBi:,LBj:,:)
3481 real(r8), intent(out) :: HnormV(LBi:,LBj:,:)
3482# ifdef SOLVE3D
3483 real(r8), intent(out) :: Hz(LBi:,LBj:,:)
3484 real(r8), intent(out) :: z_r(LBi:,LBj:,:)
3485 real(r8), intent(out) :: z_w(LBi:,LBj:,0:)
3486# endif
3487# else
3488 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
3489 real(r8), intent(in) :: om_p(LBi:UBi,LBj:UBj)
3490 real(r8), intent(in) :: om_r(LBi:UBi,LBj:UBj)
3491 real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj)
3492 real(r8), intent(in) :: om_v(LBi:UBi,LBj:UBj)
3493 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
3494 real(r8), intent(in) :: on_p(LBi:UBi,LBj:UBj)
3495 real(r8), intent(in) :: on_r(LBi:UBi,LBj:UBj)
3496 real(r8), intent(in) :: on_u(LBi:UBi,LBj:UBj)
3497 real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj)
3498 real(r8), intent(in) :: pmon_p(LBi:UBi,LBj:UBj)
3499 real(r8), intent(in) :: pmon_r(LBi:UBi,LBj:UBj)
3500 real(r8), intent(in) :: pmon_u(LBi:UBi,LBj:UBj)
3501 real(r8), intent(in) :: pnom_p(LBi:UBi,LBj:UBj)
3502 real(r8), intent(in) :: pnom_r(LBi:UBi,LBj:UBj)
3503 real(r8), intent(in) :: pnom_v(LBi:UBi,LBj:UBj)
3504# ifdef MASKING
3505 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
3506 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
3507 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
3508 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
3509# endif
3510 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
3511# ifdef SOLVE3D
3512 real(r8), intent(in) :: Kv(LBi:UBi,LBj:UBj,0:N(ng))
3513# ifdef ICESHELF
3514 real(r8), intent(in) :: zice(LBi:UBi,LBj:UBj)
3515# endif
3516# if defined SEDIMENT && defined SED_MORPH
3517 real(r8), intent(in):: bed_thick(LBi:UBi,LBj:UBj,3)
3518# endif
3519 real(r8), intent(inout) :: h(LBi:UBi,LBj:UBj)
3520# endif
3521# ifdef ADJUST_BOUNDARY
3522# ifdef SOLVE3D
3523 real(r8), intent(out) :: VnormRobc(LBij:UBij,N(ng),4,NT(ng))
3524 real(r8), intent(out) :: VnormUobc(LBij:UBij,N(ng),4)
3525 real(r8), intent(out) :: VnormVobc(LBij:UBij,N(ng),4)
3526# endif
3527 real(r8), intent(out) :: HnormRobc(LBij:UBij,4)
3528 real(r8), intent(out) :: HnormUobc(LBij:UBij,4)
3529 real(r8), intent(out) :: HnormVobc(LBij:UBij,4)
3530# endif
3531# ifdef ADJUST_WSTRESS
3532 real(r8), intent(out) :: HnormSUS(LBi:UBi,LBj:UBj)
3533 real(r8), intent(out) :: HnormSVS(LBi:UBi,LBj:UBj)
3534# endif
3535# if defined ADJUST_STFLUX && defined SOLVE3D
3536 real(r8), intent(out) :: HnormSTF(LBi:UBi,LBj:UBj,NT(ng))
3537# endif
3538# ifdef SOLVE3D
3539 real(r8), intent(out) :: VnormR(LBi:UBi,LBj:UBj,N(ng),NSA,NT(ng))
3540 real(r8), intent(out) :: VnormU(LBi:UBi,LBj:UBj,N(ng),NSA)
3541 real(r8), intent(out) :: VnormV(LBi:UBi,LBj:UBj,N(ng),NSA)
3542# endif
3543 real(r8), intent(out) :: HnormR(LBi:UBi,LBj:UBj,NSA)
3544 real(r8), intent(out) :: HnormU(LBi:UBi,LBj:UBj,NSA)
3545 real(r8), intent(out) :: HnormV(LBi:UBi,LBj:UBj,NSA)
3546# ifdef SOLVE3D
3547 real(r8), intent(out) :: Hz(LBi:UBi,LBj:UBj,N(ng))
3548 real(r8), intent(out) :: z_r(LBi:UBi,LBj:UBj,N(ng))
3549 real(r8), intent(out) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
3550# endif
3551# endif
3552
3553
3554
3555# ifdef SOLVE3D
3556 logical :: Ldiffer, Lsame
3557# endif
3558# ifdef ADJUST_BOUNDARY
3559 logical :: Lconvolve(4)
3560# endif
3561
3562 integer :: i, ifile, is, iter, j, rec
3563# ifdef SOLVE3D
3564 integer :: UBt, itrc, k
3565# endif
3566# ifdef ADJUST_BOUNDARY
3567 integer :: IJlen, IJKlen, ib, ibry, ic, ifield
3568# endif
3569 integer :: start(4), total(4)
3570
3571 real(dp) :: my_time
3572 real(r8) :: Aavg, Amax, Amin, Asqr, FacAvg, FacSqr
3573 real(r8) :: cff, val
3574
3575# ifdef ADJUST_BOUNDARY
3576 real(r8) :: Bavg, Bmin, Bmax, Bsqr
3577
3578 real(r8), parameter :: Aspv = 0.0_r8
3579# endif
3580
3581 real(r8), dimension(LBi:UBi,LBj:UBj) :: A2d
3582 real(r8), dimension(LBi:UBi,LBj:UBj) :: A2davg
3583 real(r8), dimension(LBi:UBi,LBj:UBj) :: A2dsqr
3584 real(r8), dimension(LBi:UBi,LBj:UBj) :: Hscale
3585# ifdef ADJUST_BOUNDARY
3586 real(r8), dimension(LBij:UBij) :: B2d
3587 real(r8), dimension(LBij:UBij) :: B2davg
3588 real(r8), dimension(LBij:UBij) :: B2dsqr
3589 real(r8), dimension(LBij:UBij) :: HscaleB
3590# endif
3591# ifdef SOLVE3D
3592 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: A3d
3593 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: A3davg
3594 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: A3dsqr
3595 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: Vscale
3596# ifdef ADJUST_BOUNDARY
3597 real(r8), dimension(LBij:UBij,1:N(ng)) :: B3d
3598 real(r8), dimension(LBij:UBij,1:N(ng)) :: B3davg
3599 real(r8), dimension(LBij:UBij,1:N(ng)) :: B3dsqr
3600 real(r8), dimension(LBij:UBij,1:N(ng)) :: VscaleB
3601# ifdef DISTRIBUTE
3602 real(r8), dimension((UBij-LBij+1)*N(ng)) :: Bwrk
3603# endif
3604# endif
3605# endif
3606
3607 character (len=40 ) :: Text
3608 character (len=256) :: ncname
3609
3610 character (len=*), parameter :: MyFile = &
3611 & __FILE__//", randomization_tile"
3612
3613# if defined PIO_LIB && defined DISTRIBUTE
3614
3615 TYPE (IO_Desc_t), pointer :: ioDesc
3616# endif
3617
3618# include "set_bounds.h"
3619
3620 sourcefile=myfile
3621
3622 my_time=tdays(ng)*day2sec
3623
3624# ifdef SOLVE3D
3625
3626
3627
3628
3629
3630 DO i=lbi,ubi
3631 DO j=lbj,ubj
3632 a2d(i,j)=0.0_r8
3633 END DO
3634 END DO
3635
3636 CALL set_depth_tile (ng, tile, inlm, &
3637 & lbi, ubi, lbj, ubj, &
3638 & imins, imaxs, jmins, jmaxs, &
3639 & nstp, nnew, &
3640 & h, &
3641# ifdef ICESHELF
3642 & zice, &
3643# endif
3644# if defined SEDIMENT && defined SED_MORPH
3645 & bed_thick, &
3646# endif
3647 & a2d, &
3648 & hz, z_r, z_w)
3649# endif
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666 IF (master) WRITE (stdout,10)
3667
3668 file_loop : DO ifile=1,nsa
3669
3670 IF (lwrtnrm(ifile,ng)) THEN
3671 IF (ifile.eq.1) THEN
3672 text='initial conditions'
3673 ELSE IF (ifile.eq.2) THEN
3674 text='model'
3675 END IF
3676
3677
3678
3679 facavg=1.0_r8/real(nrandom,r8)
3680 facsqr=sqrt(real(nrandom,r8))
3681
3682
3683
3684 ncname=nrm(ifile,ng)%name
3685 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
3686 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
3687
3688
3689
3690 SELECT CASE (nrm(ifile,ng)%IOtype)
3691 CASE (io_nf90)
3692 CALL netcdf_put_fvar (ng, itlm, ncname, &
3693 & vname(1,idtime), my_time, &
3694 & start = (/nrm(ifile,ng)%Rindex/), &
3695 & total = (/1/), &
3696 & ncid = nrm(ifile,ng)%ncid, &
3697 & varid = nrm(ifile,ng)%Vid(idtime))
3698# if defined PIO_LIB && defined DISTRIBUTE
3699 CASE (io_pio)
3700 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
3701 & vname(1,idtime), my_time, &
3702 & start = (/nrm(ifile,ng)%Rindex/), &
3703 & total = (/1/), &
3704 & piofile = nrm(ifile,ng)%pioFile, &
3705 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
3706# endif
3707 END SELECT
3708 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3709
3710
3711
3712 IF (cnorm(ifile,isfsur)) THEN
3713 IF (master) THEN
3714 WRITE (stdout,20) trim(text), &
3715 & '2D normalization factors at RHO-points'
3716 FLUSH (stdout)
3717 END IF
3718 DO j=jstrt,jendt
3719 DO i=istrt,iendt
3720 a2davg(i,j)=0.0_r8
3721 a2dsqr(i,j)=0.0_r8
3722 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
3723 END DO
3724 END DO
3725 DO iter=1,nrandom
3726 CALL white_noise2d (ng, itlm, r2dvar, rscheme(ng), &
3727 & istrr, iendr, jstrr, jendr, &
3728 & lbi, ubi, lbj, ubj, &
3729 & amin, amax, a2d)
3730 DO j=jstrt,jendt
3731 DO i=istrt,iendt
3732 a2d(i,j)=a2d(i,j)*hscale(i,j)
3733 END DO
3734 END DO
3735 CALL tl_conv_r2d_tile (ng, tile, itlm, &
3736 & lbi, ubi, lbj, ubj, &
3737 & imins, imaxs, jmins, jmaxs, &
3738 & nghostpoints, &
3739 & nhsteps(ifile,isfsur)/ifac, &
3740 & dtsizeh(ifile,isfsur), &
3741 & kh, &
3742 & pm, pn, pmon_u, pnom_v, &
3743# ifdef MASKING
3744 & rmask, umask, vmask, &
3745# endif
3746 & a2d)
3747 DO j=jstr,jend
3748 DO i=istr,iend
3749 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3750 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3751 END DO
3752 END DO
3753 END DO
3754 DO j=jstr,jend
3755 DO i=istr,iend
3756 aavg=facavg*a2davg(i,j)
3757 asqr=facavg*a2dsqr(i,j)
3758# ifdef MASKING
3759 IF (rmask(i,j).gt.0.0_r8) THEN
3760 hnormr(i,j,ifile)=1.0_r8/sqrt(asqr)
3761 ELSE
3762 hnormr(i,j,ifile)=0.0_r8
3763 END IF
3764# else
3765 hnormr(i,j,ifile)=1.0_r8/sqrt(asqr)
3766# endif
3767 END DO
3768 END DO
3769 CALL dabc_r2d_tile (ng, tile, &
3770 & lbi, ubi, lbj, ubj, &
3771 & hnormr(:,:,ifile))
3772# ifdef DISTRIBUTE
3773 CALL mp_exchange2d (ng, tile, itlm, 1, &
3774 & lbi, ubi, lbj, ubj, &
3775 & nghostpoints, &
3776 & ewperiodic(ng), nsperiodic(ng), &
3777 & hnormr(:,:,ifile))
3778# endif
3779
3780 SELECT CASE (nrm(ifile,ng)%IOtype)
3781 CASE (io_nf90)
3782 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3783 & lbi, ubi, lbj, ubj, idfsur, &
3784 & nrm(ifile,ng)%ncid, &
3785 & nrm(ifile,ng)%Vid(idfsur), &
3786 & nrm(ifile,ng)%Rindex, &
3787# ifdef MASKING
3788 & rmask, &
3789# endif
3790 & hnormr(:,:,ifile))
3791
3792# if defined PIO_LIB && defined DISTRIBUTE
3793 CASE (io_pio)
3794 IF (nrm(ifile,ng)%pioVar(idfsur)%dkind.eq. &
3795 & pio_double) THEN
3796 iodesc => iodesc_dp_r2dvar(ng)
3797 ELSE
3798 iodesc => iodesc_sp_r2dvar(ng)
3799 END IF
3800 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3801 & lbi, ubi, lbj, ubj, idfsur, &
3802 & nrm(ifile,ng)%pioFile, &
3803 & nrm(ifile,ng)%pioVar(idfsur), &
3804 & nrm(ifile,ng)%Rindex, &
3805 & iodesc, &
3806# ifdef MASKING
3807 & rmask, &
3808# endif
3809 & hnormr(:,:,ifile))
3810# endif
3811 END SELECT
3812 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3813 END IF
3814
3815
3816
3817 IF (cnorm(ifile,isubar)) THEN
3818 IF (master) THEN
3819 WRITE (stdout,20) trim(text), &
3820 & '2D normalization factors at U-points'
3821 FLUSH (stdout)
3822 END IF
3823 DO j=jstrt,jendt
3824 DO i=istrp,iendt
3825 a2davg(i,j)=0.0_r8
3826 a2dsqr(i,j)=0.0_r8
3827 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
3828 END DO
3829 END DO
3830 DO iter=1,nrandom
3831 CALL white_noise2d (ng, itlm, u2dvar, rscheme(ng), &
3832 & istr, iendr, jstrr, jendr, &
3833 & lbi, ubi, lbj, ubj, &
3834 & amin, amax, a2d)
3835 DO j=jstrt,jendt
3836 DO i=istrp,iendt
3837 a2d(i,j)=a2d(i,j)*hscale(i,j)
3838 END DO
3839 END DO
3840 CALL tl_conv_u2d_tile (ng, tile, itlm, &
3841 & lbi, ubi, lbj, ubj, &
3842 & imins, imaxs, jmins, jmaxs, &
3843 & nghostpoints, &
3844 & nhsteps(ifile,isubar)/ifac, &
3845 & dtsizeh(ifile,isubar), &
3846 & kh, &
3847 & pm, pn, pmon_r, pnom_p, &
3848# ifdef MASKING
3849 & umask, pmask, &
3850# endif
3851 & a2d)
3852 DO j=jstr,jend
3853 DO i=istru,iend
3854 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3855 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3856 END DO
3857 END DO
3858 END DO
3859 DO j=jstr,jend
3860 DO i=istru,iend
3861 aavg=facavg*a2davg(i,j)
3862 asqr=facavg*a2dsqr(i,j)
3863# ifdef MASKING
3864 IF (umask(i,j).gt.0.0_r8) THEN
3865 hnormu(i,j,ifile)=1.0_r8/sqrt(asqr)
3866 ELSE
3867 hnormu(i,j,ifile)=0.0_r8
3868 END IF
3869# else
3870 hnormu(i,j,ifile)=1.0_r8/sqrt(asqr)
3871# endif
3872 END DO
3873 END DO
3874 CALL dabc_u2d_tile (ng, tile, &
3875 & lbi, ubi, lbj, ubj, &
3876 & hnormu(:,:,ifile))
3877# ifdef DISTRIBUTE
3878 CALL mp_exchange2d (ng, tile, itlm, 1, &
3879 & lbi, ubi, lbj, ubj, &
3880 & nghostpoints, &
3881 & ewperiodic(ng), nsperiodic(ng), &
3882 & hnormu(:,:,ifile))
3883# endif
3884
3885 SELECT CASE (nrm(ifile,ng)%IOtype)
3886 CASE (io_nf90)
3887 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3888 & lbi, ubi, lbj, ubj, idubar, &
3889 & nrm(ifile,ng)%ncid, &
3890 & nrm(ifile,ng)%Vid(idubar), &
3891 & nrm(ifile,ng)%Rindex, &
3892# ifdef MASKING
3893 & umask, &
3894# endif
3895 & hnormu(:,:,ifile))
3896
3897# if defined PIO_LIB && defined DISTRIBUTE
3898 CASE (io_pio)
3899 IF (nrm(ifile,ng)%pioVar(idubar)%dkind.eq. &
3900 & pio_double) THEN
3901 iodesc => iodesc_dp_u2dvar(ng)
3902 ELSE
3903 iodesc => iodesc_sp_u2dvar(ng)
3904 END IF
3905 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3906 & lbi, ubi, lbj, ubj, idubar, &
3907 & nrm(ifile,ng)%pioFile, &
3908 & nrm(ifile,ng)%pioVar(idubar), &
3909 & nrm(ifile,ng)%Rindex, &
3910 & iodesc, &
3911# ifdef MASKING
3912 & umask, &
3913# endif
3914 & hnormu(:,:,ifile))
3915# endif
3916 END SELECT
3917 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3918 END IF
3919
3920
3921
3922 IF (cnorm(ifile,isvbar)) THEN
3923 IF (master) THEN
3924 WRITE (stdout,20) trim(text), &
3925 & '2D normalization factors at V-points'
3926 FLUSH (stdout)
3927 END IF
3928 DO j=jstrp,jendt
3929 DO i=istrt,iendt
3930 a2davg(i,j)=0.0_r8
3931 a2dsqr(i,j)=0.0_r8
3932 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
3933 END DO
3934 END DO
3935 DO iter=1,nrandom
3936 CALL white_noise2d (ng, itlm, v2dvar, rscheme(ng), &
3937 & istrr, iendr, jstr, jendr, &
3938 & lbi, ubi, lbj, ubj, &
3939 & amin, amax, a2d)
3940 DO j=jstrp,jendt
3941 DO i=istrt,iendt
3942 a2d(i,j)=a2d(i,j)*hscale(i,j)
3943 END DO
3944 END DO
3945 CALL tl_conv_v2d_tile (ng, tile, itlm, &
3946 & lbi, ubi, lbj, ubj, &
3947 & imins, imaxs, jmins, jmaxs, &
3948 & nghostpoints, &
3949 & nhsteps(ifile,isvbar)/ifac, &
3950 & dtsizeh(ifile,isvbar), &
3951 & kh, &
3952 & pm, pn, pmon_p, pnom_r, &
3953# ifdef MASKING
3954 & vmask, pmask, &
3955# endif
3956 & a2d)
3957 DO j=jstrv,jend
3958 DO i=istr,iend
3959 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3960 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3961 END DO
3962 END DO
3963 END DO
3964 DO j=jstrv,jend
3965 DO i=istr,iend
3966 aavg=facavg*a2davg(i,j)
3967 asqr=facavg*a2dsqr(i,j)
3968# ifdef MASKING
3969 IF (vmask(i,j).gt.0.0_r8) THEN
3970 hnormv(i,j,ifile)=1.0_r8/sqrt(asqr)
3971 ELSE
3972 hnormv(i,j,ifile)=0.0_r8
3973 END IF
3974# else
3975 hnormv(i,j,ifile)=1.0_r8/sqrt(asqr)
3976# endif
3977 END DO
3978 END DO
3979 CALL dabc_v2d_tile (ng, tile, &
3980 & lbi, ubi, lbj, ubj, &
3981 & hnormv(:,:,ifile))
3982# ifdef DISTRIBUTE
3983 CALL mp_exchange2d (ng, tile, itlm, 1, &
3984 & lbi, ubi, lbj, ubj, &
3985 & nghostpoints, &
3986 & ewperiodic(ng), nsperiodic(ng), &
3987 & hnormv(:,:,ifile))
3988# endif
3989
3990 SELECT CASE (nrm(ifile,ng)%IOtype)
3991 CASE (io_nf90)
3992 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3993 & lbi, ubi, lbj, ubj, idvbar, &
3994 & nrm(ifile,ng)%ncid, &
3995 & nrm(ifile,ng)%Vid(idvbar), &
3996 & nrm(ifile,ng)%Rindex, &
3997# ifdef MASKING
3998 & vmask, &
3999# endif
4000 & hnormv(:,:,ifile))
4001
4002# if defined PIO_LIB && defined DISTRIBUTE
4003 CASE (io_pio)
4004 IF (nrm(ifile,ng)%pioVar(idvbar)%dkind.eq. &
4005 & pio_double) THEN
4006 iodesc => iodesc_dp_v2dvar(ng)
4007 ELSE
4008 iodesc => iodesc_sp_v2dvar(ng)
4009 END IF
4010 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
4011 & lbi, ubi, lbj, ubj, idvbar, &
4012 & nrm(ifile,ng)%pioFile, &
4013 & nrm(ifile,ng)%pioVar(idvbar), &
4014 & nrm(ifile,ng)%Rindex, &
4015 & iodesc, &
4016# ifdef MASKING
4017 & vmask, &
4018# endif
4019 & hnormv(:,:,ifile))
4020# endif
4021 END SELECT
4022 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4023 END IF
4024
4025# ifdef SOLVE3D
4026
4027
4028
4029 IF (cnorm(ifile,isuvel)) THEN
4030 IF (master) THEN
4031 WRITE (stdout,20) trim(text), &
4032 & '3D normalization factors at U-points'
4033 FLUSH (stdout)
4034 END IF
4035 DO j=jstrt,jendt
4036 DO i=istrp,iendt
4037 val=om_u(i,j)*on_u(i,j)*0.5_r8
4038 DO k=1,n(ng)
4039 a3davg(i,j,k)=0.0_r8
4040 a3dsqr(i,j,k)=0.0_r8
4041 vscale(i,j,k)=1.0_r8/sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4042 END DO
4043 END DO
4044 END DO
4045 DO iter=1,nrandom
4046 CALL white_noise3d (ng, itlm, u3dvar, rscheme(ng), &
4047 & istr, iendr, jstrr, jendr, &
4048 & lbi, ubi, lbj, ubj, 1, n(ng), &
4049 & amin, amax, a3d)
4050 DO k=1,n(ng)
4051 DO j=jstrt,jendt
4052 DO i=istrp,iendt
4053 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4054 END DO
4055 END DO
4056 END DO
4057 CALL tl_conv_u3d_tile (ng, tile, itlm, &
4058 & lbi, ubi, lbj, ubj, 1, n(ng), &
4059 & imins, imaxs, jmins, jmaxs, &
4060 & nghostpoints, &
4061 & nhsteps(ifile,isuvel)/ifac, &
4062 & nvsteps(ifile,isuvel)/ifac, &
4063 & dtsizeh(ifile,isuvel), &
4064 & dtsizev(ifile,isuvel), &
4065 & kh, kv, &
4066 & pm, pn, &
4067# ifdef GEOPOTENTIAL_HCONV
4068 & on_r, om_p, &
4069# else
4070 & pmon_r, pnom_p, &
4071# endif
4072# ifdef MASKING
4073# ifdef GEOPOTENTIAL_HCONV
4074 & pmask, rmask, umask, vmask, &
4075# else
4076 & umask, pmask, &
4077# endif
4078# endif
4079 & hz, z_r, &
4080 & a3d)
4081 DO k=1,n(ng)
4082 DO j=jstr,jend
4083 DO i=istru,iend
4084 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4085 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4086 END DO
4087 END DO
4088 END DO
4089 END DO
4090 DO k=1,n(ng)
4091 DO j=jstr,jend
4092 DO i=istru,iend
4093 aavg=facavg*a3davg(i,j,k)
4094 asqr=facavg*a3dsqr(i,j,k)
4095# ifdef MASKING
4096 IF (umask(i,j).gt.0.0_r8) THEN
4097 vnormu(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4098 ELSE
4099 vnormu(i,j,k,ifile)=0.0_r8
4100 END IF
4101# else
4102 vnormu(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4103# endif
4104 END DO
4105 END DO
4106 END DO
4107 CALL dabc_u3d_tile (ng, tile, &
4108 & lbi, ubi, lbj, ubj, 1, n(ng), &
4109 & vnormu(:,:,:,ifile))
4110# ifdef DISTRIBUTE
4111 CALL mp_exchange3d (ng, tile, itlm, 1, &
4112 & lbi, ubi, lbj, ubj, 1, n(ng), &
4113 & nghostpoints, &
4114 & ewperiodic(ng), nsperiodic(ng), &
4115 & vnormu(:,:,:,ifile))
4116# endif
4117
4118 SELECT CASE (nrm(ifile,ng)%IOtype)
4119 CASE (io_nf90)
4120 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4121 & lbi, ubi, lbj, ubj, 1, n(ng), &
4122 & iduvel, nrm(ifile,ng)%ncid, &
4123 & nrm(ifile,ng)%Vid(iduvel), &
4124 & nrm(ifile,ng)%Rindex, &
4125# ifdef MASKING
4126 & umask, &
4127# endif
4128 & vnormu(:,:,:,ifile))
4129
4130# if defined PIO_LIB && defined DISTRIBUTE
4131 CASE (io_pio)
4132 IF (nrm(ifile,ng)%pioVar(iduvel)%dkind.eq. &
4133 & pio_double) THEN
4134 iodesc => iodesc_dp_u3dvar(ng)
4135 ELSE
4136 iodesc => iodesc_sp_u3dvar(ng)
4137 END IF
4138 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4139 & lbi, ubi, lbj, ubj, 1, n(ng), &
4140 & iduvel, nrm(ifile,ng)%pioFile, &
4141 & nrm(ifile,ng)%pioVar(iduvel), &
4142 & nrm(ifile,ng)%Rindex, &
4143 & iodesc, &
4144# ifdef MASKING
4145 & umask, &
4146# endif
4147 & vnormu(:,:,:,ifile))
4148# endif
4149 END SELECT
4150 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4151 END IF
4152
4153
4154
4155 IF (cnorm(ifile,isvvel)) THEN
4156 IF (master) THEN
4157 WRITE (stdout,20) trim(text), &
4158 & '3D normalization factors at V-points'
4159 FLUSH (stdout)
4160 END IF
4161 DO j=jstrp,jendt
4162 DO i=istrt,iendt
4163 val=om_v(i,j)*on_v(i,j)*0.5_r8
4164 DO k=1,n(ng)
4165 a3davg(i,j,k)=0.0_r8
4166 a3dsqr(i,j,k)=0.0_r8
4167 vscale(i,j,k)=1.0_r8/sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
4168 END DO
4169 END DO
4170 END DO
4171 DO iter=1,nrandom
4172 CALL white_noise3d (ng, itlm, v3dvar, rscheme(ng), &
4173 & istrr, iendr, jstr, jendr, &
4174 & lbi, ubi, lbj, ubj, 1, n(ng), &
4175 & amin, amax, a3d)
4176 DO k=1,n(ng)
4177 DO j=jstrp,jendt
4178 DO i=istrt,iendt
4179 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4180 END DO
4181 END DO
4182 END DO
4183 CALL tl_conv_v3d_tile (ng, tile, itlm, &
4184 & lbi, ubi, lbj, ubj, 1, n(ng), &
4185 & imins, imaxs, jmins, jmaxs, &
4186 & nghostpoints, &
4187 & nhsteps(ifile,isvvel)/ifac, &
4188 & nvsteps(ifile,isvvel)/ifac, &
4189 & dtsizeh(ifile,isvvel), &
4190 & dtsizev(ifile,isvvel), &
4191 & kh, kv, &
4192 & pm, pn, &
4193# ifdef GEOPOTENTIAL_HCONV
4194 & on_p, om_r, &
4195# else
4196 & pmon_p, pnom_r, &
4197# endif
4198# ifdef MASKING
4199# ifdef GEOPOTENTIAL_HCONV
4200 & pmask, rmask, umask, vmask, &
4201# else
4202 & vmask, pmask, &
4203# endif
4204# endif
4205 & hz, z_r, &
4206 & a3d)
4207 DO k=1,n(ng)
4208 DO j=jstrv,jend
4209 DO i=istr,iend
4210 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4211 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4212 END DO
4213 END DO
4214 END DO
4215 END DO
4216 DO k=1,n(ng)
4217 DO j=jstrv,jend
4218 DO i=istr,iend
4219 aavg=facavg*a3davg(i,j,k)
4220 asqr=facavg*a3dsqr(i,j,k)
4221# ifdef MASKING
4222 IF (vmask(i,j).gt.0.0_r8) THEN
4223 vnormv(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4224 ELSE
4225 vnormv(i,j,k,ifile)=0.0_r8
4226 END IF
4227# else
4228 vnormv(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4229# endif
4230 END DO
4231 END DO
4232 END DO
4233 CALL dabc_v3d_tile (ng, tile, &
4234 & lbi, ubi, lbj, ubj, 1, n(ng), &
4235 & vnormv(:,:,:,ifile))
4236# ifdef DISTRIBUTE
4237 CALL mp_exchange3d (ng, tile, itlm, 1, &
4238 & lbi, ubi, lbj, ubj, 1, n(ng), &
4239 & nghostpoints, &
4240 & ewperiodic(ng), nsperiodic(ng), &
4241 & vnormv(:,:,:,ifile))
4242# endif
4243
4244 SELECT CASE (nrm(ifile,ng)%IOtype)
4245 CASE (io_nf90)
4246 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4247 & lbi, ubi, lbj, ubj, 1, n(ng), &
4248 & idvvel, nrm(ifile,ng)%ncid, &
4249 & nrm(ifile,ng)%Vid(idvvel), &
4250 & nrm(ifile,ng)%Rindex, &
4251# ifdef MASKING
4252 & vmask, &
4253# endif
4254 & vnormv(:,:,:,ifile))
4255
4256# if defined PIO_LIB && defined DISTRIBUTE
4257 CASE (io_pio)
4258 IF (nrm(ifile,ng)%pioVar(idvvel)%dkind.eq. &
4259 & pio_double) THEN
4260 iodesc => iodesc_dp_v3dvar(ng)
4261 ELSE
4262 iodesc => iodesc_sp_v3dvar(ng)
4263 END IF
4264 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4265 & lbi, ubi, lbj, ubj, 1, n(ng), &
4266 & idvvel, nrm(ifile,ng)%pioFile, &
4267 & nrm(ifile,ng)%pioVar(idvvel), &
4268 & nrm(ifile,ng)%Rindex, &
4269 & iodesc, &
4270# ifdef MASKING
4271 & vmask, &
4272# endif
4273 & vnormv(:,:,:,ifile))
4274# endif
4275 END SELECT
4276 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4277 END IF
4278
4279
4280
4281 IF (master) THEN
4282 lsame=.false.
4283 DO itrc=1,nt(ng)
4284 is=istvar(itrc)
4285 IF (cnorm(ifile,is)) lsame=.true.
4286 END DO
4287 IF (lsame) THEN
4288 WRITE (stdout,20) trim(text), &
4289 & '3D normalization factors at RHO-points'
4290 FLUSH (stdout)
4291 END IF
4292 END IF
4293
4294
4295
4296
4297
4298
4299 ldiffer=.false.
4300 DO itrc=2,nt(ng)
4301 IF ((hdecay(ifile,istvar(itrc ),ng).ne. &
4302 & hdecay(ifile,istvar(itrc-1),ng)).or. &
4303 & (vdecay(ifile,istvar(itrc ),ng).ne. &
4304 & vdecay(ifile,istvar(itrc-1),ng))) THEN
4305 ldiffer=.true.
4306 END IF
4307 END DO
4308 IF (.not.ldiffer) THEN
4309 lsame=.true.
4310 ubt=1
4311 ELSE
4312 lsame=.false.
4313 ubt=nt(ng)
4314 END IF
4315
4316 DO j=jstrt,jendt
4317 DO i=istrt,iendt
4318 val=om_r(i,j)*on_r(i,j)
4319 DO k=1,n(ng)
4320 vscale(i,j,k)=1.0_r8/sqrt(val*hz(i,j,k))
4321 END DO
4322 END DO
4323 END DO
4324 DO itrc=1,ubt
4325 is=istvar(itrc)
4326 IF (cnorm(ifile,is)) THEN
4327 DO k=1,n(ng)
4328 DO j=jstrt,jendt
4329 DO i=istrt,iendt
4330 a3davg(i,j,k)=0.0_r8
4331 a3dsqr(i,j,k)=0.0_r8
4332 END DO
4333 END DO
4334 END DO
4335 DO iter=1,nrandom
4336 CALL white_noise3d (ng, itlm, r3dvar, rscheme(ng), &
4337 & istrr, iendr, jstrr, jendr, &
4338 & lbi, ubi, lbj, ubj, 1, n(ng), &
4339 & amin, amax, a3d)
4340 DO k=1,n(ng)
4341 DO j=jstrt,jendt
4342 DO i=istrt,iendt
4343 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4344 END DO
4345 END DO
4346 END DO
4347 CALL tl_conv_r3d_tile (ng, tile, itlm, &
4348 & lbi, ubi, lbj, ubj, 1, n(ng), &
4349 & imins, imaxs, jmins, jmaxs, &
4350 & nghostpoints, &
4351 & nhsteps(ifile,is)/ifac, &
4352 & nvsteps(ifile,is)/ifac, &
4353 & dtsizeh(ifile,is), &
4354 & dtsizev(ifile,is), &
4355 & kh, kv, &
4356 & pm, pn, &
4357# ifdef GEOPOTENTIAL_HCONV
4358 & on_u, om_v, &
4359# else
4360 & pmon_u, pnom_v, &
4361# endif
4362# ifdef MASKING
4363 & rmask, umask, vmask, &
4364# endif
4365 & hz, z_r, &
4366 & a3d)
4367 DO k=1,n(ng)
4368 DO j=jstr,jend
4369 DO i=istr,iend
4370 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4371 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4372 END DO
4373 END DO
4374 END DO
4375 END DO
4376 DO k=1,n(ng)
4377 DO j=jstr,jend
4378 DO i=istr,iend
4379 aavg=facavg*a3davg(i,j,k)
4380 asqr=facavg*a3dsqr(i,j,k)
4381# ifdef MASKING
4382 IF (rmask(i,j).gt.0.0_r8) THEN
4383 vnormr(i,j,k,ifile,itrc)=1.0_r8/sqrt(asqr)
4384 ELSE
4385 vnormr(i,j,k,ifile,itrc)=0.0_r8
4386 END IF
4387# else
4388 vnormr(i,j,k,ifile,itrc)=1.0_r8/sqrt(asqr)
4389# endif
4390 END DO
4391 END DO
4392 END DO
4393 END IF
4394 END DO
4395 IF (lsame) THEN
4396 DO itrc=2,nt(ng)
4397 DO k=1,n(ng)
4398 DO j=jstr,jend
4399 DO i=istr,iend
4400 vnormr(i,j,k,ifile,itrc)=vnormr(i,j,k,ifile,1)
4401 END DO
4402 END DO
4403 END DO
4404 END DO
4405 END IF
4406 DO itrc=1,nt(ng)
4407 is=istvar(itrc)
4408 IF (cnorm(ifile,is)) THEN
4409 CALL dabc_r3d_tile (ng, tile, &
4410 & lbi, ubi, lbj, ubj, 1, n(ng), &
4411 & vnormr(:,:,:,ifile,itrc))
4412# ifdef DISTRIBUTE
4413 CALL mp_exchange3d (ng, tile, itlm, 1, &
4414 & lbi, ubi, lbj, ubj, 1, n(ng), &
4415 & nghostpoints, &
4416 & ewperiodic(ng), nsperiodic(ng), &
4417 & vnormr(:,:,:,ifile,itrc))
4418# endif
4419
4420 SELECT CASE (nrm(ifile,ng)%IOtype)
4421 CASE (io_nf90)
4422 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4423 & lbi, ubi, lbj, ubj, 1, n(ng), &
4424 & idtvar(itrc), &
4425 & nrm(ifile,ng)%ncid, &
4426 & nrm(ifile,ng)%Vid(idtvar(itrc)), &
4427 & nrm(ifile,ng)%Rindex, &
4428# ifdef MASKING
4429 & rmask, &
4430# endif
4431 & vnormr(:,:,:,ifile,itrc))
4432
4433# if defined PIO_LIB && defined DISTRIBUTE
4434 CASE (io_pio)
4435 IF (nrm(ifile,ng)%pioTrc(itrc)%dkind.eq. &
4436 & pio_double) THEN
4437 iodesc => iodesc_dp_r3dvar(ng)
4438 ELSE
4439 iodesc => iodesc_sp_r3dvar(ng)
4440 END IF
4441 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4442 & lbi, ubi, lbj, ubj, 1, n(ng), &
4443 & idtvar(itrc), &
4444 & nrm(ifile,ng)%pioFile, &
4445 & nrm(ifile,ng)%pioTrc(itrc), &
4446 & nrm(ifile,ng)%Rindex, &
4447 & iodesc, &
4448# ifdef MASKING
4449 & rmask, &
4450# endif
4451 & vnormr(:,:,:,ifile,itrc))
4452# endif
4453 END SELECT
4454 IF (founderror(exit_flag, noerror, &
4455 & __line__, myfile)) RETURN
4456 END IF
4457 END DO
4458# endif
4459 END IF
4460 END DO file_loop
4461
4462# ifdef ADJUST_BOUNDARY
4463
4464
4465
4466
4467
4468
4469 ifile=3
4470 IF (lwrtnrm(ifile,ng)) THEN
4471 text='boundary conditions'
4472 ijlen=ubij-lbij+1
4473# ifdef SOLVE3D
4474 ijklen=ijlen*n(ng)
4475# endif
4476 lconvolve(iwest )=domain(ng)%Western_Edge (tile)
4477 lconvolve(ieast )=domain(ng)%Eastern_Edge (tile)
4478 lconvolve(isouth)=domain(ng)%Southern_Edge(tile)
4479 lconvolve(inorth)=domain(ng)%Northern_Edge(tile)
4480
4481
4482
4483 facavg=1.0_r8/real(nrandom,r8)
4484 facsqr=sqrt(real(nrandom,r8))
4485
4486
4487
4488 ncname=nrm(ifile,ng)%name
4489 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
4490 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
4491
4492
4493
4494 SELECT CASE (nrm(ifile,ng)%IOtype)
4495 CASE (io_nf90)
4496 CALL netcdf_put_fvar (ng, itlm, ncname, &
4497 & vname(1,idtime), my_time, &
4498 & start = (/nrm(ifile,ng)%Rindex/), &
4499 & total = (/1/), &
4500 & ncid = nrm(ifile,ng)%ncid, &
4501 & varid = nrm(ifile,ng)%Vid(idtime))
4502
4503# if defined PIO_LIB && defined DISTRIBUTE
4504 CASE (io_pio)
4505 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4506 & vname(1,idtime), my_time, &
4507 & start = (/nrm(ifile,ng)%Rindex/), &
4508 & total = (/1/), &
4509 & piofile = nrm(ifile,ng)%pioFile, &
4510 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
4511# endif
4512 END SELECT
4513 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4514
4515
4516
4517 hnormrobc=aspv
4518
4519 IF (master.and.any(cnormb(isfsur,:))) THEN
4520 WRITE (stdout,20) trim(text), &
4521 & '2D normalization factors at RHO-points'
4522 FLUSH (stdout)
4523 END IF
4524
4525 DO ibry=1,4
4526 IF (cnormb(isfsur,ibry)) THEN
4527 hscaleb=0.0_r8
4528 b2davg=0.0_r8
4529 b2dsqr=0.0_r8
4530 b2d=0.0_r8
4531 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4532 i=bounds(ng)%edge(ibry,r2dvar)
4533 IF (lconvolve(ibry)) THEN
4534 DO j=jstrt,jendt
4535 hscaleb(j)=1.0_r8/sqrt(on_r(i,j))
4536 END DO
4537 END IF
4538 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4539 j=bounds(ng)%edge(ibry,r2dvar)
4540 IF (lconvolve(ibry)) THEN
4541 DO i=istrt,iendt
4542 hscaleb(i)=1.0_r8/sqrt(om_r(i,j))
4543 END DO
4544 END IF
4545 END IF
4546 DO iter=1,nrandom
4547 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4548 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4549 & rscheme(ng), &
4550 & jstrr, jendr, &
4551 & lbij, ubij, &
4552 & bmin, bmax, b2d)
4553 DO j=jstrt,jendt
4554 b2d(j)=b2d(j)*hscaleb(j)
4555 END DO
4556 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4557 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4558 & rscheme(ng), &
4559 & istrr, iendr, &
4560 & lbij, ubij, &
4561 & bmin, bmax, b2d)
4562 DO i=istrt,iendt
4563 b2d(i)=b2d(i)*hscaleb(i)
4564 END DO
4565 END IF
4566 CALL tl_conv_r2d_bry_tile (ng, tile, itlm, ibry, &
4567 & bounds(ng)%edge(:,r2dvar), &
4568 & lbij, ubij, &
4569 & lbi, ubi, lbj, ubj, &
4570 & imins, imaxs, jmins, jmaxs, &
4571 & nghostpoints, &
4572 & nhstepsb(ibry,isfsur)/ifac, &
4573 & dtsizehb(ibry,isfsur), &
4574 & kh, &
4575 & pm, pn, pmon_u, pnom_v, &
4576# ifdef MASKING
4577 & rmask, umask, vmask, &
4578# endif
4579 & b2d)
4580 IF (lconvolve(ibry)) THEN
4581 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4582 DO j=jstr,jend
4583 b2davg(j)=b2davg(j)+b2d(j)
4584 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4585 END DO
4586 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4587 DO i=istr,iend
4588 b2davg(i)=b2davg(i)+b2d(i)
4589 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4590 END DO
4591 END IF
4592 END IF
4593 END DO
4594 IF (lconvolve(ibry)) THEN
4595 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4596 DO j=jstr,jend
4597 bavg=facavg*b2davg(j)
4598 bsqr=facavg*b2dsqr(j)
4599# ifdef MASKING
4600 IF (rmask(i,j).gt.0.0_r8) THEN
4601 hnormrobc(j,ibry)=1.0_r8/sqrt(bsqr)
4602 ELSE
4603 hnormrobc(j,ibry)=0.0_r8
4604 END IF
4605# else
4606 hnormrobc(j,ibry)=1.0_r8/sqrt(bsqr)
4607# endif
4608 END DO
4609 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4610 DO i=istr,iend
4611 bavg=facavg*b2davg(i)
4612 bsqr=facavg*b2dsqr(i)
4613# ifdef MASKING
4614 IF (rmask(i,j).gt.0.0_r8) THEN
4615 hnormrobc(i,ibry)=1.0_r8/sqrt(bsqr)
4616 ELSE
4617 hnormrobc(i,ibry)=0.0_r8
4618 END IF
4619# else
4620 hnormrobc(i,ibry)=1.0_r8/sqrt(bsqr)
4621# endif
4622 END DO
4623 END IF
4624 END IF
4625 CALL bc_r2d_bry_tile (ng, tile, ibry, &
4626 & lbij, ubij, &
4627 & hnormrobc(:,ibry))
4628# ifdef DISTRIBUTE
4629 CALL mp_collect (ng, itlm, ijlen, aspv, &
4630 & hnormrobc(lbij:,ibry))
4631# endif
4632 END IF
4633 END DO
4634 IF (any(cnormb(isfsur,:))) THEN
4635 ifield=idsbry(isfsur)
4636
4637 SELECT CASE (nrm(ifile,ng)%IOtype)
4638 CASE (io_nf90)
4639 CALL netcdf_put_fvar (ng, itlm, ncname, &
4640 & vname(1,ifield), &
4641 & hnormrobc(lbij:,:), &
4642 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4643 & total = (/ijlen,4,1/), &
4644 & ncid = nrm(ifile,ng)%ncid, &
4645 & varid = nrm(ifile,ng)%Vid(ifield))
4646
4647# if defined PIO_LIB && defined DISTRIBUTE
4648 CASE (io_pio)
4649 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4650 & vname(1,ifield), &
4651 & hnormrobc(lbij:,:), &
4652 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4653 & total = (/ijlen,4,1/), &
4654 & piofile = nrm(ifile,ng)%pioFile, &
4655 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4656
4657# endif
4658 END SELECT
4659 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4660 END IF
4661
4662
4663
4664 hnormuobc=aspv
4665
4666 IF (master.and.any(cnormb(isubar,:))) THEN
4667 WRITE (stdout,20) trim(text), &
4668 & '2D normalization factors at U-points'
4669 FLUSH (stdout)
4670 END IF
4671
4672 DO ibry=1,4
4673 IF (cnormb(isubar,ibry)) THEN
4674 hscaleb=0.0_r8
4675 b2davg=0.0_r8
4676 b2dsqr=0.0_r8
4677 b2d=0.0_r8
4678 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4679 i=bounds(ng)%edge(ibry,u2dvar)
4680 IF (lconvolve(ibry)) THEN
4681 DO j=jstrt,jendt
4682 hscaleb(j)=1.0_r8/sqrt(on_u(i,j))
4683 END DO
4684 END IF
4685 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4686 j=bounds(ng)%edge(ibry,u2dvar)
4687 IF (lconvolve(ibry)) THEN
4688 DO i=istrp,iendt
4689 hscaleb(i)=1.0_r8/sqrt(om_u(i,j))
4690 END DO
4691 END IF
4692 END IF
4693 DO iter=1,nrandom
4694 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4695 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4696 & rscheme(ng), &
4697 & jstrr, jendr, &
4698 & lbij, ubij, &
4699 & bmin, bmax, b2d)
4700 DO j=jstrt,jendt
4701 b2d(j)=b2d(j)*hscaleb(j)
4702 END DO
4703 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4704 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4705 & rscheme(ng), &
4706 & istr, iendr, &
4707 & lbij, ubij, &
4708 & bmin, bmax, b2d)
4709 DO i=istrp,iendt
4710 b2d(i)=b2d(i)*hscaleb(i)
4711 END DO
4712 END IF
4713 CALL tl_conv_u2d_bry_tile (ng, tile, itlm, ibry, &
4714 & bounds(ng)%edge(:,u2dvar), &
4715 & lbij, ubij, &
4716 & lbi, ubi, lbj, ubj, &
4717 & imins, imaxs, jmins, jmaxs, &
4718 & nghostpoints, &
4719 & nhstepsb(ibry,isubar)/ifac, &
4720 & dtsizehb(ibry,isubar), &
4721 & kh, &
4722 & pm, pn, pmon_r, pnom_p, &
4723# ifdef MASKING
4724 & umask, pmask, &
4725# endif
4726 & b2d)
4727 IF (lconvolve(ibry)) THEN
4728 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4729 DO j=jstr,jend
4730 b2davg(j)=b2davg(j)+b2d(j)
4731 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4732 END DO
4733 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4734 DO i=istru,iend
4735 b2davg(i)=b2davg(i)+b2d(i)
4736 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4737 END DO
4738 END IF
4739 END IF
4740 END DO
4741 IF (lconvolve(ibry)) THEN
4742 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4743 DO j=jstr,jend
4744 bavg=facavg*b2davg(j)
4745 bsqr=facavg*b2dsqr(j)
4746# ifdef MASKING
4747 IF (umask(i,j).gt.0.0_r8) THEN
4748 hnormuobc(j,ibry)=1.0_r8/sqrt(bsqr)
4749 ELSE
4750 hnormuobc(j,ibry)=0.0_r8
4751 END IF
4752# else
4753 hnormuobc(j,ibry)=1.0_r8/sqrt(bsqr)
4754# endif
4755 END DO
4756 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4757 DO i=istru,iend
4758 bavg=facavg*b2davg(i)
4759 bsqr=facavg*b2dsqr(i)
4760# ifdef MASKING
4761 IF (umask(i,j).gt.0.0_r8) THEN
4762 hnormuobc(i,ibry)=1.0_r8/sqrt(bsqr)
4763 ELSE
4764 hnormuobc(i,ibry)=0.0_r8
4765 END IF
4766# else
4767 hnormuobc(i,ibry)=1.0_r8/sqrt(bsqr)
4768# endif
4769 END DO
4770 END IF
4771 END IF
4772 CALL bc_u2d_bry_tile (ng, tile, ibry, &
4773 & lbij, ubij, &
4774 & hnormuobc(:,ibry))
4775# ifdef DISTRIBUTE
4776 CALL mp_collect (ng, itlm, ijlen, aspv, &
4777 & hnormuobc(lbij:,ibry))
4778# endif
4779 END IF
4780 END DO
4781 IF (any(cnormb(isubar,:))) THEN
4782 ifield=idsbry(isubar)
4783
4784 SELECT CASE (nrm(ifile,ng)%IOtype)
4785 CASE (io_nf90)
4786 CALL netcdf_put_fvar (ng, itlm, ncname, &
4787 & vname(1,ifield), &
4788 & hnormuobc(lbij:,:), &
4789 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4790 & total = (/ijlen,4,1/), &
4791 & ncid = nrm(ifile,ng)%ncid, &
4792 & varid = nrm(ifile,ng)%Vid(ifield))
4793
4794# if defined PIO_LIB && defined DISTRIBUTE
4795 CASE (io_pio)
4796 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4797 & vname(1,ifield), &
4798 & hnormuobc(lbij:,:), &
4799 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4800 & total = (/ijlen,4,1/), &
4801 & piofile = nrm(ifile,ng)%pioFile, &
4802 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4803# endif
4804 END SELECT
4805 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4806 END IF
4807
4808
4809
4810 hnormvobc=aspv
4811
4812 IF (master.and.any(cnormb(isvbar,:))) THEN
4813 WRITE (stdout,20) trim(text), &
4814 & '2D normalization factors at V-points'
4815 FLUSH (stdout)
4816 END IF
4817
4818 DO ibry=1,4
4819 IF (cnormb(isvbar,ibry)) THEN
4820 hscaleb=0.0_r8
4821 b2davg=0.0_r8
4822 b2dsqr=0.0_r8
4823 b2d=0.0_r8
4824 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4825 i=bounds(ng)%edge(ibry,v2dvar)
4826 IF (lconvolve(ibry)) THEN
4827 DO j=jstrp,jendt
4828 hscaleb(j)=1.0_r8/sqrt(on_v(i,j))
4829 END DO
4830 END IF
4831 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4832 j=bounds(ng)%edge(ibry,v2dvar)
4833 IF (lconvolve(ibry)) THEN
4834 DO i=istrt,iendt
4835 hscaleb(i)=1.0_r8/sqrt(om_v(i,j))
4836 END DO
4837 END IF
4838 END IF
4839 DO iter=1,nrandom
4840 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4841 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4842 & rscheme(ng), &
4843 & jstr, jendr, &
4844 & lbij, ubij, &
4845 & bmin, bmax, b2d)
4846 DO j=jstrp,jendt
4847 b2d(j)=b2d(j)*hscaleb(j)
4848 END DO
4849 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4850 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4851 & rscheme(ng), &
4852 & istrr, iendr, &
4853 & lbij, ubij, &
4854 & bmin, bmax, b2d)
4855 DO i=istrt,iendt
4856 b2d(i)=b2d(i)*hscaleb(i)
4857 END DO
4858 END IF
4859 CALL tl_conv_v2d_bry_tile (ng, tile, itlm, ibry, &
4860 & bounds(ng)%edge(:,v2dvar), &
4861 & lbij, ubij, &
4862 & lbi, ubi, lbj, ubj, &
4863 & imins, imaxs, jmins, jmaxs, &
4864 & nghostpoints, &
4865 & nhstepsb(ibry,isfsur)/ifac, &
4866 & dtsizehb(ibry,isfsur), &
4867 & kh, &
4868 & pm, pn, pmon_p, pnom_r, &
4869# ifdef MASKING
4870 & vmask, pmask, &
4871# endif
4872 & b2d)
4873 IF (lconvolve(ibry)) THEN
4874 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4875 DO j=jstrv,jend
4876 b2davg(j)=b2davg(j)+b2d(j)
4877 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4878 END DO
4879 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4880 DO i=istr,iend
4881 b2davg(i)=b2davg(i)+b2d(i)
4882 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4883 END DO
4884 END IF
4885 END IF
4886 END DO
4887 IF (lconvolve(ibry)) THEN
4888 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4889 DO j=jstrv,jend
4890 bavg=facavg*b2davg(j)
4891 bsqr=facavg*b2dsqr(j)
4892# ifdef MASKING
4893 IF (vmask(i,j).gt.0.0_r8) THEN
4894 hnormvobc(j,ibry)=1.0_r8/sqrt(bsqr)
4895 ELSE
4896 hnormvobc(j,ibry)=0.0_r8
4897 END IF
4898# else
4899 hnormvobc(j,ibry)=1.0_r8/sqrt(bsqr)
4900# endif
4901 END DO
4902 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4903 DO i=istr,iend
4904 bavg=facavg*b2davg(i)
4905 bsqr=facavg*b2dsqr(i)
4906# ifdef MASKING
4907 IF (vmask(i,j).gt.0.0_r8) THEN
4908 hnormvobc(i,ibry)=1.0_r8/sqrt(bsqr)
4909 ELSE
4910 hnormvobc(i,ibry)=0.0_r8
4911 END IF
4912# else
4913 hnormvobc(i,ibry)=1.0_r8/sqrt(bsqr)
4914# endif
4915 END DO
4916 END IF
4917 END IF
4918 CALL bc_v2d_bry_tile (ng, tile, ibry, &
4919 & lbij, ubij, &
4920 & hnormvobc(:,ibry))
4921# ifdef DISTRIBUTE
4922 CALL mp_collect (ng, itlm, ijlen, aspv, &
4923 & hnormvobc(lbij:,ibry))
4924# endif
4925 END IF
4926 END DO
4927 IF (any(cnormb(isvbar,:))) THEN
4928 ifield=idsbry(isvbar)
4929
4930 SELECT CASE (nrm(ifile,ng)%IOtype)
4931 CASE (io_nf90)
4932 CALL netcdf_put_fvar (ng, itlm, ncname, &
4933 & vname(1,ifield), &
4934 & hnormvobc(lbij:,:), &
4935 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4936 & total = (/ijlen,4,1/), &
4937 & ncid = nrm(ifile,ng)%ncid, &
4938 & varid = nrm(ifile,ng)%Vid(ifield))
4939
4940# if defined PIO_LIB && defined DISTRIBUTE
4941 CASE (io_pio)
4942 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4943 & vname(1,ifield), &
4944 & hnormvobc(lbij:,:), &
4945 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4946 & total = (/ijlen,4,1/), &
4947 & piofile = nrm(ifile,ng)%pioFile, &
4948 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4949# endif
4950 END SELECT
4951 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4952 END IF
4953
4954# ifdef SOLVE3D
4955
4956
4957
4958 vnormuobc=aspv
4959
4960 IF (master.and.any(cnormb(isuvel,:))) THEN
4961 WRITE (stdout,20) trim(text), &
4962 & '3D normalization factors at U-points'
4963 FLUSH (stdout)
4964 END IF
4965
4966 DO ibry=1,4
4967 IF (cnormb(isuvel,ibry)) THEN
4968 vscaleb=0.0_r8
4969 b3davg=0.0_r8
4970 b3dsqr=0.0_r8
4971 b3d=0.0_r8
4972 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4973 i=bounds(ng)%edge(ibry,u2dvar)
4974 IF (lconvolve(ibry)) THEN
4975 DO j=jstrt,jendt
4976 val=on_u(i,j)*0.5_r8
4977 DO k=1,n(ng)
4978 vscaleb(j,k)=1.0_r8/ &
4979 & sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4980 END DO
4981 END DO
4982 END IF
4983 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4984 j=bounds(ng)%edge(ibry,u2dvar)
4985 IF (lconvolve(ibry)) THEN
4986 DO i=istrp,iendt
4987 val=om_u(i,j)*0.5_r8
4988 DO k=1,n(ng)
4989 vscaleb(i,k)=1.0_r8/ &
4990 & sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4991 END DO
4992 END DO
4993 END IF
4994 END IF
4995 DO iter=1,nrandom
4996 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4997 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
4998 & rscheme(ng), &
4999 & jstrr, jendr, &
5000 & lbij, ubij, 1, n(ng), &
5001 & bmin, bmax, b3d)
5002 DO k=1,n(ng)
5003 DO j=jstrt,jendt
5004 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5005 END DO
5006 END DO
5007 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5008 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5009 & rscheme(ng), &
5010 & istr, iendr, &
5011 & lbij, ubij, 1, n(ng), &
5012 & bmin, bmax, b3d)
5013 DO k=1,n(ng)
5014 DO i=istrp,iendt
5015 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5016 END DO
5017 END DO
5018 END IF
5019 CALL tl_conv_u3d_bry_tile (ng, tile, itlm, ibry, &
5020 & bounds(ng)%edge(:,u2dvar), &
5021 & lbij, ubij, &
5022 & lbi, ubi, lbj, ubj, 1, n(ng), &
5023 & imins, imaxs, jmins, jmaxs, &
5024 & nghostpoints, &
5025 & nhstepsb(ibry,isuvel)/ifac, &
5026 & nvstepsb(ibry,isuvel)/ifac, &
5027 & dtsizehb(ibry,isuvel), &
5028 & dtsizevb(ibry,isuvel), &
5029 & kh, kv, &
5030 & pm, pn, &
5031 & pmon_r, pnom_p, &
5032# ifdef MASKING
5033 & umask, pmask, &
5034# endif
5035 & hz, z_r, &
5036 & b3d)
5037 IF (lconvolve(ibry)) THEN
5038 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5039 DO k=1,n(ng)
5040 DO j=jstr,jend
5041 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5042 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5043 END DO
5044 END DO
5045 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5046 DO k=1,n(ng)
5047 DO i=istru,iend
5048 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5049 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5050 END DO
5051 END DO
5052 END IF
5053 END IF
5054 END DO
5055 IF (lconvolve(ibry)) THEN
5056 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5057 DO k=1,n(ng)
5058 DO j=jstr,jend
5059 bavg=facavg*b3davg(j,k)
5060 bsqr=facavg*b3dsqr(j,k)
5061# ifdef MASKING
5062 IF (umask(i,j).gt.0.0_r8) THEN
5063 vnormuobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5064 ELSE
5065 vnormuobc(j,k,ibry)=0.0_r8
5066 END IF
5067# else
5068 vnormuobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5069# endif
5070 END DO
5071 END DO
5072 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5073 DO k=1,n(ng)
5074 DO i=istru,iend
5075 bavg=facavg*b3davg(i,k)
5076 bsqr=facavg*b3dsqr(i,k)
5077# ifdef MASKING
5078 IF (umask(i,j).gt.0.0_r8) THEN
5079 vnormuobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5080 ELSE
5081 vnormuobc(i,k,ibry)=0.0_r8
5082 END IF
5083# else
5084 vnormuobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5085# endif
5086 END DO
5087 END DO
5088 END IF
5089 END IF
5090 CALL bc_u3d_bry_tile (ng, tile, ibry, &
5091 & lbij, ubij, 1, n(ng), &
5092 & vnormuobc(:,:,ibry))
5093# ifdef DISTRIBUTE
5094 bwrk=reshape(vnormuobc(:,:,ibry), (/ijklen/))
5095 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5096 ic=0
5097 DO k=1,n(ng)
5098 DO ib=lbij,ubij
5099 ic=ic+1
5100 vnormuobc(ib,k,ibry)=bwrk(ic)
5101 END DO
5102 END DO
5103# endif
5104 END IF
5105 END DO
5106 IF (any(cnormb(isuvel,:))) THEN
5107 ifield=idsbry(isuvel)
5108
5109 SELECT CASE (nrm(ifile,ng)%IOtype)
5110 CASE (io_nf90)
5111 CALL netcdf_put_fvar (ng, itlm, ncname, &
5112 & vname(1,ifield), &
5113 & vnormuobc(lbij:,:,:), &
5114 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5115 & total = (/ijlen,n(ng),4,1/), &
5116 & ncid = nrm(ifile,ng)%ncid, &
5117 & varid = nrm(ifile,ng)%Vid(ifield))
5118
5119# if defined PIO_LIB && defined DISTRIBUTE
5120 CASE (io_pio)
5121 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5122 & vname(1,ifield), &
5123 & vnormuobc(lbij:,:,:), &
5124 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5125 & total = (/ijlen,n(ng),4,1/), &
5126 & piofile = nrm(ifile,ng)%pioFile, &
5127 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5128# endif
5129 END SELECT
5130 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5131 END IF
5132
5133
5134
5135 vnormvobc=aspv
5136
5137 IF (master.and.any(cnormb(isvvel,:))) THEN
5138 WRITE (stdout,20) trim(text), &
5139 & '3D normalization factors at V-points'
5140 FLUSH (stdout)
5141 END IF
5142
5143 DO ibry=1,4
5144 IF (cnormb(isvvel,ibry)) THEN
5145 vscaleb=0.0_r8
5146 b3davg=0.0_r8
5147 b3dsqr=0.0_r8
5148 b3d=0.0_r8
5149 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5150 i=bounds(ng)%edge(ibry,v2dvar)
5151 IF (lconvolve(ibry)) THEN
5152 DO j=jstrp,jendt
5153 val=on_v(i,j)*0.5_r8
5154 DO k=1,n(ng)
5155 vscaleb(j,k)=1.0_r8/ &
5156 & sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
5157 END DO
5158 END DO
5159 END IF
5160 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5161 j=bounds(ng)%edge(ibry,v2dvar)
5162 IF (lconvolve(ibry)) THEN
5163 DO i=istrt,iendt
5164 val=om_v(i,j)*0.5_r8
5165 DO k=1,n(ng)
5166 vscaleb(i,k)=1.0_r8/ &
5167 & sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
5168 END DO
5169 END DO
5170 END IF
5171 END IF
5172 DO iter=1,nrandom
5173 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5174 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5175 & rscheme(ng), &
5176 & jstr, jendr, &
5177 & lbij, ubij, 1, n(ng), &
5178 & bmin, bmax, b3d)
5179 DO k=1,n(ng)
5180 DO j=jstrp,jendt
5181 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5182 END DO
5183 END DO
5184 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5185 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5186 & rscheme(ng), &
5187 & istrr, iendr, &
5188 & lbij, ubij, 1, n(ng), &
5189 & bmin, bmax, b3d)
5190 DO k=1,n(ng)
5191 DO i=istrt,iendt
5192 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5193 END DO
5194 END DO
5195 END IF
5196 CALL tl_conv_v3d_bry_tile (ng, tile, itlm, ibry, &
5197 & bounds(ng)%edge(:,v2dvar), &
5198 & lbij, ubij, &
5199 & lbi, ubi, lbj, ubj, 1, n(ng), &
5200 & imins, imaxs, jmins, jmaxs, &
5201 & nghostpoints, &
5202 & nhstepsb(ibry,isvvel)/ifac, &
5203 & nvstepsb(ibry,isvvel)/ifac, &
5204 & dtsizehb(ibry,isvvel), &
5205 & dtsizevb(ibry,isvvel), &
5206 & kh, kv, &
5207 & pm, pn, &
5208 & pmon_p, pnom_r, &
5209# ifdef MASKING
5210 & vmask, pmask, &
5211# endif
5212 & hz, z_r, &
5213 & b3d)
5214 IF (lconvolve(ibry)) THEN
5215 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5216 DO k=1,n(ng)
5217 DO j=jstrv,jend
5218 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5219 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5220 END DO
5221 END DO
5222 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5223 DO k=1,n(ng)
5224 DO i=istr,iend
5225 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5226 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5227 END DO
5228 END DO
5229 END IF
5230 END IF
5231 END DO
5232 IF (lconvolve(ibry)) THEN
5233 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5234 DO k=1,n(ng)
5235 DO j=jstrv,jend
5236 bavg=facavg*b3davg(j,k)
5237 bsqr=facavg*b3dsqr(j,k)
5238# ifdef MASKING
5239 IF (vmask(i,j).gt.0.0_r8) THEN
5240 vnormvobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5241 ELSE
5242 vnormvobc(j,k,ibry)=0.0_r8
5243 END IF
5244# else
5245 vnormvobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5246# endif
5247 END DO
5248 END DO
5249 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5250 DO k=1,n(ng)
5251 DO i=istr,iend
5252 bavg=facavg*b3davg(i,k)
5253 bsqr=facavg*b3dsqr(i,k)
5254# ifdef MASKING
5255 IF (vmask(i,j).gt.0.0_r8) THEN
5256 vnormvobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5257 ELSE
5258 vnormvobc(i,k,ibry)=0.0_r8
5259 END IF
5260# else
5261 vnormvobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5262# endif
5263 END DO
5264 END DO
5265 END IF
5266 END IF
5267 CALL bc_v3d_bry_tile (ng, tile, ibry, &
5268 & lbij, ubij, 1, n(ng), &
5269 & vnormvobc(:,:,ibry))
5270# ifdef DISTRIBUTE
5271 bwrk=reshape(vnormvobc(:,:,ibry), (/ijklen/))
5272 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5273 ic=0
5274 DO k=1,n(ng)
5275 DO ib=lbij,ubij
5276 ic=ic+1
5277 vnormvobc(ib,k,ibry)=bwrk(ic)
5278 END DO
5279 END DO
5280# endif
5281 END IF
5282 END DO
5283 IF (any(cnormb(isvvel,:))) THEN
5284 ifield=idsbry(isvvel)
5285
5286 SELECT CASE (nrm(ifile,ng)%IOtype)
5287 CASE (io_nf90)
5288 CALL netcdf_put_fvar (ng, itlm, ncname, &
5289 & vname(1,ifield), &
5290 & vnormvobc(lbij:,:,:), &
5291 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5292 & total = (/ijlen,n(ng),4,1/), &
5293 & ncid = nrm(ifile,ng)%ncid, &
5294 & varid = nrm(ifile,ng)%Vid(ifield))
5295
5296# if defined PIO_LIB && defined DISTRIBUTE
5297 CASE (io_pio)
5298 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5299 & vname(1,ifield), &
5300 & vnormvobc(lbij:,:,:), &
5301 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5302 & total = (/ijlen,n(ng),4,1/), &
5303 & piofile = nrm(ifile,ng)%pioFile, &
5304 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5305# endif
5306 END SELECT
5307 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5308 END IF
5309
5310
5311
5312 IF (master) THEN
5313 DO itrc=1,nt(ng)
5314 is=istvar(itrc)
5315 IF (any(cnormb(is,:))) THEN
5316 lsame=.true.
5317 EXIT
5318 END IF
5319 END DO
5320 IF (lsame) THEN
5321 WRITE (stdout,20) trim(text), &
5322 & '3D normalization factors at RHO-points'
5323 FLUSH (stdout)
5324 END IF
5325 END IF
5326
5327 DO itrc=1,nt(ng)
5328 vnormrobc=aspv
5329 is=istvar(itrc)
5330 DO ibry=1,4
5331 IF (cnormb(is,ibry)) THEN
5332 vscaleb=0.0_r8
5333 b3davg=0.0_r8
5334 b3dsqr=0.0_r8
5335 b3d=0.0_r8
5336 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5337 i=bounds(ng)%edge(ibry,r2dvar)
5338 IF (lconvolve(ibry)) THEN
5339 DO j=jstrt,jendt
5340 val=on_r(i,j)
5341 DO k=1,n(ng)
5342 vscaleb(j,k)=1.0_r8/sqrt(val*hz(i,j,k))
5343 END DO
5344 END DO
5345 END IF
5346 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5347 j=bounds(ng)%edge(ibry,r2dvar)
5348 IF (lconvolve(ibry)) THEN
5349 DO i=istrt,iendt
5350 val=om_r(i,j)
5351 DO k=1,n(ng)
5352 vscaleb(i,k)=1.0_r8/sqrt(val*hz(i,j,k))
5353 END DO
5354 END DO
5355 END IF
5356 END IF
5357 DO iter=1,nrandom
5358 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5359 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5360 & rscheme(ng), &
5361 & jstrr, jendr, &
5362 & lbij, ubij, 1, n(ng), &
5363 & bmin, bmax, b3d)
5364 DO k=1,n(ng)
5365 DO j=jstrt,jendt
5366 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5367 END DO
5368 END DO
5369 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5370 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5371 & rscheme(ng), &
5372 & istrr, iendr, &
5373 & lbij, ubij, 1, n(ng), &
5374 & bmin, bmax, b3d)
5375 DO k=1,n(ng)
5376 DO i=istrt,iendt
5377 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5378 END DO
5379 END DO
5380 END IF
5381 CALL tl_conv_r3d_bry_tile (ng, tile, itlm, ibry, &
5382 & bounds(ng)%edge(:,r2dvar), &
5383 & lbij, ubij, &
5384 & lbi, ubi, lbj, ubj, &
5385 & 1, n(ng), &
5386 & imins, imaxs, jmins, jmaxs, &
5387 & nghostpoints, &
5388 & nhstepsb(ibry,is)/ifac, &
5389 & nvstepsb(ibry,is)/ifac, &
5390 & dtsizehb(ibry,is), &
5391 & dtsizevb(ibry,is), &
5392 & kh, kv, &
5393 & pm, pn, &
5394 & pmon_u, pnom_v, &
5395# ifdef MASKING
5396 & rmask, umask, vmask, &
5397# endif
5398 & hz, z_r, &
5399 & b3d)
5400 IF (lconvolve(ibry)) THEN
5401 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5402 DO k=1,n(ng)
5403 DO j=jstr,jend
5404 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5405 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5406 END DO
5407 END DO
5408 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5409 DO k=1,n(ng)
5410 DO i=istr,iend
5411 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5412 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5413 END DO
5414 END DO
5415 END IF
5416 END IF
5417 END DO
5418 IF (lconvolve(ibry)) THEN
5419 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5420 DO k=1,n(ng)
5421 DO j=jstr,jend
5422 bavg=facavg*b3davg(j,k)
5423 bsqr=facavg*b3dsqr(j,k)
5424# ifdef MASKING
5425 IF (rmask(i,j).gt.0.0_r8) THEN
5426 vnormrobc(j,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5427 ELSE
5428 vnormrobc(j,k,ibry,itrc)=0.0_r8
5429 END IF
5430# else
5431 vnormrobc(j,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5432# endif
5433 END DO
5434 END DO
5435 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5436 DO k=1,n(ng)
5437 DO i=istr,iend
5438 bavg=facavg*b3davg(i,k)
5439 bsqr=facavg*b3dsqr(i,k)
5440# ifdef MASKING
5441 IF (rmask(i,j).gt.0.0_r8) THEN
5442 vnormrobc(i,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5443 ELSE
5444 vnormrobc(i,k,ibry,itrc)=0.0_r8
5445 END IF
5446# else
5447 vnormrobc(i,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5448# endif
5449 END DO
5450 END DO
5451 END IF
5452 END IF
5453 CALL bc_r3d_bry_tile (ng, tile, ibry, &
5454 & lbij, ubij, 1, n(ng), &
5455 & vnormrobc(:,:,ibry,itrc))
5456# ifdef DISTRIBUTE
5457 bwrk=reshape(vnormrobc(:,:,ibry,itrc), (/ijklen/))
5458 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5459 ic=0
5460 DO k=1,n(ng)
5461 DO ib=lbij,ubij
5462 ic=ic+1
5463 vnormrobc(ib,k,ibry,itrc)=bwrk(ic)
5464 END DO
5465 END DO
5466# endif
5467 END IF
5468 END DO
5469 IF (any(cnormb(is,:))) THEN
5470 ifield=idsbry(istvar(itrc))
5471
5472 SELECT CASE (nrm(ifile,ng)%IOtype)
5473 CASE (io_nf90)
5474 CALL netcdf_put_fvar (ng, itlm, ncname, &
5475 & vname(1,ifield), &
5476 & vnormrobc(lbij:,:,:,itrc), &
5477 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
5478 & total = (/ijlen,n(ng),4,1/), &
5479 & ncid = nrm(ifile,ng)%ncid, &
5480 & varid = nrm(ifile,ng)%Vid(ifield))
5481
5482# if defined PIO_LIB && defined DISTRIBUTE
5483 CASE (io_pio)
5484 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5485 & vname(1,ifield), &
5486 & vnormrobc(lbij:,:,:,itrc), &
5487 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
5488 & total = (/ijlen,n(ng),4,1/), &
5489 & piofile = nrm(ifile,ng)%pioFile, &
5490 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5491# endif
5492 END SELECT
5493 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5494 END IF
5495 END DO
5496# endif
5497
5498
5499
5500
5501
5502 SELECT CASE (nrm(ifile,ng)%IOtype)
5503 CASE (io_nf90)
5504 CALL netcdf_sync (ng, itlm, ncname, &
5505 & nrm(ifile,ng)%ncid)
5506# if defined PIO_LIB && defined DISTRIBUTE
5507 CASE (io_pio)
5508 CALL pio_netcdf_sync (ng, itlm, ncname, &
5509 & nrm(ifile,ng)%pioFile)
5510# endif
5511 END SELECT
5512 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5513 END IF
5514# endif
5515
5516# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
5517
5518
5519
5520
5521
5522
5523 ifile=4
5524 IF (lwrtnrm(ifile,ng)) THEN
5525 rec=1
5526 text='surface forcing'
5527
5528
5529
5530 facavg=1.0_r8/real(nrandom,r8)
5531 facsqr=sqrt(real(nrandom,r8))
5532
5533
5534
5535 ncname=nrm(ifile,ng)%name
5536 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
5537 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
5538
5539
5540
5541 SELECT CASE (nrm(ifile,ng)%IOtype)
5542 CASE (io_nf90)
5543 CALL netcdf_put_fvar (ng, itlm, ncname, &
5544 & vname(1,idtime), my_time, &
5545 & start = (/nrm(ifile,ng)%Rindex/), &
5546 & total = (/1/), &
5547 & ncid = nrm(ifile,ng)%ncid, &
5548 & varid = nrm(ifile,ng)%Vid(idtime))
5549
5550# if defined PIO_LIB && defined DISTRIBUTE
5551 CASE (io_pio)
5552 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5553 & vname(1,idtime), my_time, &
5554 & start = (/nrm(ifile,ng)%Rindex/), &
5555 & total = (/1/), &
5556 & piofile = nrm(ifile,ng)%pioFile, &
5557 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
5558# endif
5559 END SELECT
5560 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5561
5562# ifdef ADJUST_WSTRESS
5563
5564
5565
5566 IF (cnorm(rec,isustr)) THEN
5567 IF (master) THEN
5568 WRITE (stdout,20) trim(text), &
5569 & '2D normalization factors at U-points'
5570 FLUSH (stdout)
5571 END IF
5572 DO j=jstrt,jendt
5573 DO i=istrp,iendt
5574 a2davg(i,j)=0.0_r8
5575 a2dsqr(i,j)=0.0_r8
5576 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
5577 END DO
5578 END DO
5579 DO iter=1,nrandom
5580 CALL white_noise2d (ng, itlm, u2dvar, rscheme(ng), &
5581 & istr, iendr, jstrr, jendr, &
5582 & lbi, ubi, lbj, ubj, &
5583 & amin, amax, a2d)
5584 DO j=jstrt,jendt
5585 DO i=istrp,iendt
5586 a2d(i,j)=a2d(i,j)*hscale(i,j)
5587 END DO
5588 END DO
5589 CALL tl_conv_u2d_tile (ng, tile, itlm, &
5590 & lbi, ubi, lbj, ubj, &
5591 & imins, imaxs, jmins, jmaxs, &
5592 & nghostpoints, &
5593 & nhsteps(rec,isustr)/ifac, &
5594 & dtsizeh(rec,isustr), &
5595 & kh, &
5596 & pm, pn, pmon_r, pnom_p, &
5597# ifdef MASKING
5598 & umask, pmask, &
5599# endif
5600 & a2d)
5601 DO j=jstr,jend
5602 DO i=istru,iend
5603 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5604 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5605 END DO
5606 END DO
5607 END DO
5608 DO j=jstr,jend
5609 DO i=istru,iend
5610 aavg=facavg*a2davg(i,j)
5611 asqr=facavg*a2dsqr(i,j)
5612# ifdef MASKING
5613 IF (umask(i,j).gt.0.0_r8) THEN
5614 hnormsus(i,j)=1.0_r8/sqrt(asqr)
5615 ELSE
5616 hnormsus(i,j)=0.0_r8
5617 END IF
5618# else
5619 hnormsus(i,j)=1.0_r8/sqrt(asqr)
5620# endif
5621 END DO
5622 END DO
5623 CALL dabc_u2d_tile (ng, tile, &
5624 & lbi, ubi, lbj, ubj, &
5625 & hnormsus)
5626# ifdef DISTRIBUTE
5627 CALL mp_exchange2d (ng, tile, itlm, 1, &
5628 & lbi, ubi, lbj, ubj, &
5629 & nghostpoints, &
5630 & ewperiodic(ng), nsperiodic(ng), &
5631 & hnormsus)
5632# endif
5633
5634 SELECT CASE (nrm(ifile,ng)%IOtype)
5635 CASE (io_nf90)
5636 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5637 & lbi, ubi, lbj, ubj, idusms, &
5638 & nrm(ifile,ng)%ncid, &
5639 & nrm(ifile,ng)%Vid(idusms), &
5640 & nrm(ifile,ng)%Rindex, &
5641# ifdef MASKING
5642 & umask, &
5643# endif
5644 & hnormsus)
5645
5646# if defined PIO_LIB && defined DISTRIBUTE
5647 CASE (io_pio)
5648 IF (nrm(ifile,ng)%pioVar(idusms)%dkind.eq. &
5649 & pio_double) THEN
5650 iodesc => iodesc_dp_u2dvar(ng)
5651 ELSE
5652 iodesc => iodesc_sp_u2dvar(ng)
5653 END IF
5654 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5655 & lbi, ubi, lbj, ubj, idusms, &
5656 & nrm(ifile,ng)%pioFile, &
5657 & nrm(ifile,ng)%pioVar(idusms), &
5658 & nrm(ifile,ng)%Rindex, &
5659 & iodesc, &
5660# ifdef MASKING
5661 & umask, &
5662# endif
5663 & hnormsus)
5664# endif
5665 END SELECT
5666 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5667 END IF
5668
5669
5670
5671 IF (cnorm(rec,isvstr)) THEN
5672 IF (master) THEN
5673 WRITE (stdout,20) trim(text), &
5674 & '2D normalization factors at V-points'
5675 FLUSH (stdout)
5676 END IF
5677 DO j=jstrp,jendt
5678 DO i=istrt,iendt
5679 a2davg(i,j)=0.0_r8
5680 a2dsqr(i,j)=0.0_r8
5681 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
5682 END DO
5683 END DO
5684 DO iter=1,nrandom
5685 CALL white_noise2d (ng, itlm, v2dvar, rscheme(ng), &
5686 & istrr, iendr, jstr, jendr, &
5687 & lbi, ubi, lbj, ubj, &
5688 & amin, amax, a2d)
5689 DO j=jstrp,jendt
5690 DO i=istrt,iendt
5691 a2d(i,j)=a2d(i,j)*hscale(i,j)
5692 END DO
5693 END DO
5694 CALL tl_conv_v2d_tile (ng, tile, itlm, &
5695 & lbi, ubi, lbj, ubj, &
5696 & imins, imaxs, jmins, jmaxs, &
5697 & nghostpoints, &
5698 & nhsteps(rec,isvstr)/ifac, &
5699 & dtsizeh(rec,isvstr), &
5700 & kh, &
5701 & pm, pn, pmon_p, pnom_r, &
5702# ifdef MASKING
5703 & vmask, pmask, &
5704# endif
5705 & a2d)
5706 DO j=jstrv,jend
5707 DO i=istr,iend
5708 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5709 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5710 END DO
5711 END DO
5712 END DO
5713 DO j=jstrv,jend
5714 DO i=istr,iend
5715 aavg=facavg*a2davg(i,j)
5716 asqr=facavg*a2dsqr(i,j)
5717# ifdef MASKING
5718 IF (vmask(i,j).gt.0.0_r8) THEN
5719 hnormsvs(i,j)=1.0_r8/sqrt(asqr)
5720 ELSE
5721 hnormsvs(i,j)=0.0_r8
5722 END IF
5723# else
5724 hnormsvs(i,j)=1.0_r8/sqrt(asqr)
5725# endif
5726 END DO
5727 END DO
5728 CALL dabc_v2d_tile (ng, tile, &
5729 & lbi, ubi, lbj, ubj, &
5730 & hnormsvs)
5731# ifdef DISTRIBUTE
5732 CALL mp_exchange2d (ng, tile, itlm, 1, &
5733 & lbi, ubi, lbj, ubj, &
5734 & nghostpoints, &
5735 & ewperiodic(ng), nsperiodic(ng), &
5736 & hnormsvs)
5737# endif
5738
5739 SELECT CASE (nrm(ifile,ng)%IOtype)
5740 CASE (io_nf90)
5741 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5742 & lbi, ubi, lbj, ubj, idvsms, &
5743 & nrm(ifile,ng)%ncid, &
5744 & nrm(ifile,ng)%Vid(idvsms), &
5745 & nrm(ifile,ng)%Rindex, &
5746# ifdef MASKING
5747 & vmask, &
5748# endif
5749 & hnormsvs)
5750
5751# if defined PIO_LIB && defined DISTRIBUTE
5752 CASE (io_pio)
5753 IF (nrm(ifile,ng)%pioVar(idvsms)%dkind.eq. &
5754 & pio_double) THEN
5755 iodesc => iodesc_dp_v2dvar(ng)
5756 ELSE
5757 iodesc => iodesc_sp_v2dvar(ng)
5758 END IF
5759 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5760 & lbi, ubi, lbj, ubj, idvsms, &
5761 & nrm(ifile,ng)%pioFile, &
5762 & nrm(ifile,ng)%pioVar(idvsms), &
5763 & nrm(ifile,ng)%Rindex, &
5764 & iodesc, &
5765# ifdef MASKING
5766 & vmask, &
5767# endif
5768 & hnormsvs)
5769# endif
5770 END SELECT
5771 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5772 END IF
5773# endif
5774# if defined ADJUST_STFLUX && defined SOLVE3D
5775
5776
5777
5778 IF (master) THEN
5779 lsame=.false.
5780 DO itrc=1,nt(ng)
5781 IF (lstflux(itrc,ng)) THEN
5782 is=istsur(itrc)
5783 IF (cnorm(rec,is)) lsame=.true.
5784 END IF
5785 END DO
5786 IF (lsame) THEN
5787 WRITE (stdout,20) trim(text), &
5788 & '2D normalization factors at RHO-points'
5789 FLUSH (stdout)
5790 END IF
5791 END IF
5792
5793
5794
5795
5796
5797
5798 ldiffer=.false.
5799 DO itrc=2,nt(ng)
5800 IF (hdecay(rec,istvar(itrc ),ng).ne. &
5801 & hdecay(rec,istvar(itrc-1),ng)) THEN
5802 ldiffer=.true.
5803 END IF
5804 END DO
5805 IF (.not.ldiffer) THEN
5806 lsame=.true.
5807 ubt=1
5808 ELSE
5809 lsame=.false.
5810 ubt=nt(ng)
5811 END IF
5812
5813 DO j=jstrt,jendt
5814 DO i=istrt,iendt
5815 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
5816 END DO
5817 END DO
5818 DO itrc=1,ubt
5819 IF (lstflux(itrc,ng)) THEN
5820 is=istsur(itrc)
5821 IF (cnorm(rec,is)) THEN
5822 DO j=jstrt,jendt
5823 DO i=istrt,iendt
5824 a2davg(i,j)=0.0_r8
5825 a2dsqr(i,j)=0.0_r8
5826 END DO
5827 END DO
5828 DO iter=1,nrandom
5829 CALL white_noise2d (ng, itlm, r2dvar, rscheme(ng), &
5830 & istrr, iendr, jstrr, jendr, &
5831 & lbi, ubi, lbj, ubj, &
5832 & amin, amax, a2d)
5833 DO j=jstrt,jendt
5834 DO i=istrt,iendt
5835 a2d(i,j)=a2d(i,j)*hscale(i,j)
5836 END DO
5837 END DO
5838 CALL tl_conv_r2d_tile (ng, tile, itlm, &
5839 & lbi, ubi, lbj, ubj, &
5840 & imins, imaxs, jmins, jmaxs, &
5841 & nghostpoints, &
5842 & nhsteps(rec,is)/ifac, &
5843 & dtsizeh(rec,is), &
5844 & kh, &
5845 & pm, pn, pmon_u, pnom_v, &
5846# ifdef MASKING
5847 & rmask, umask, vmask, &
5848# endif
5849 & a2d)
5850 DO j=jstr,jend
5851 DO i=istr,iend
5852 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5853 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5854 END DO
5855 END DO
5856 END DO
5857 DO j=jstr,jend
5858 DO i=istr,iend
5859 aavg=facavg*a2davg(i,j)
5860 asqr=facavg*a2dsqr(i,j)
5861# ifdef MASKING
5862 IF (rmask(i,j).gt.0.0_r8) THEN
5863 hnormstf(i,j,itrc)=1.0_r8/sqrt(asqr)
5864 ELSE
5865 hnormstf(i,j,itrc)=0.0_r8
5866 END IF
5867# else
5868 hnormstf(i,j,itrc)=1.0_r8/sqrt(asqr)
5869# endif
5870 END DO
5871 END DO
5872 END IF
5873 END IF
5874 END DO
5875 IF (lsame) THEN
5876 DO itrc=2,nt(ng)
5877 IF (lstflux(itrc,ng)) THEN
5878 DO j=jstr,jend
5879 DO i=istr,iend
5880 hnormstf(i,j,itrc)=hnormstf(i,j,1)
5881 END DO
5882 END DO
5883 END IF
5884 END DO
5885 END IF
5886 DO itrc=1,nt(ng)
5887 IF (lstflux(itrc,ng)) THEN
5888 is=istsur(itrc)
5889 IF (cnorm(rec,is)) THEN
5890 CALL dabc_r2d_tile (ng, tile, &
5891 & lbi, ubi, lbj, ubj, &
5892 & hnormstf(:,:,itrc))
5893# ifdef DISTRIBUTE
5894 CALL mp_exchange2d (ng, tile, itlm, 1, &
5895 & lbi, ubi, lbj, ubj, &
5896 & nghostpoints, &
5897 & ewperiodic(ng), nsperiodic(ng), &
5898 & hnormstf(:,:,itrc))
5899# endif
5900
5901 SELECT CASE (nrm(ifile,ng)%IOtype)
5902 CASE (io_nf90)
5903 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5904 & lbi, ubi, lbj, ubj, &
5905 & idtsur(itrc), &
5906 & nrm(ifile,ng)%ncid, &
5907 & nrm(ifile,ng)%Vid(idtsur(itrc)), &
5908 & nrm(ifile,ng)%Rindex, &
5909# ifdef MASKING
5910 & rmask, &
5911# endif
5912 & hnormstf(:,:,itrc))
5913
5914# if defined PIO_LIB && defined DISTRIBUTE
5915 CASE (io_pio)
5916 IF (nrm(ifile,ng)%pioVar(idtsur(itrc))%dkind.eq. &
5917 & pio_double) THEN
5918 iodesc => iodesc_dp_r2dvar(ng)
5919 ELSE
5920 iodesc => iodesc_sp_r2dvar(ng)
5921 END IF
5922 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5923 & lbi, ubi, lbj, ubj, &
5924 & idtsur(itrc), &
5925 & nrm(ifile,ng)%pioFile, &
5926 & nrm(ifile,ng)%pioVar(idtsur(itrc)), &
5927 & nrm(ifile,ng)%Rindex, &
5928 & iodesc, &
5929# ifdef MASKING
5930 & rmask, &
5931# endif
5932 & hnormstf(:,:,itrc))
5933# endif
5934 END SELECT
5935 IF (founderror(exit_flag, noerror, &
5936 & __line__, myfile)) RETURN
5937 END IF
5938 END IF
5939 END DO
5940# endif
5941 END IF
5942# endif
5943
5944 IF (master) THEN
5945 WRITE (stdout,30)
5946 END IF
5947
5948 10 FORMAT (/,' Error Covariance Factors: Randomization Method',/)
5949 20 FORMAT (4x,'Computing',1x,a,1x,a)
5950 30 FORMAT (/)
5951
5952 RETURN