2733
2734
2735
2736
2737 integer, intent(in) :: ng, tile, model
2738 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
2739 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
2740 integer, intent(in) :: Lold, Lnew, Lwrk
2741 integer, intent(in) :: innLoop, outLoop
2742
2743# ifdef ASSUMED_SHAPE
2744# ifdef MASKING
2745 real(r8), intent(in) :: rmask(LBi:,LBj:)
2746 real(r8), intent(in) :: umask(LBi:,LBj:)
2747 real(r8), intent(in) :: vmask(LBi:,LBj:)
2748# endif
2749# ifdef ADJUST_BOUNDARY
2750# ifdef SOLVE3D
2751 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
2752 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
2753 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
2754# endif
2755 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
2756 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
2757 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
2758# endif
2759# ifdef ADJUST_WSTRESS
2760 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
2761 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
2762# endif
2763# ifdef SOLVE3D
2764# ifdef ADJUST_STFLUX
2765 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
2766# endif
2767 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
2768 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
2769 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
2770# if defined WEAK_CONSTRAINT && defined TIME_CONV
2771 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
2772 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
2773# endif
2774# else
2775 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
2776 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
2777# endif
2778 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
2779# ifdef ADJUST_BOUNDARY
2780# ifdef SOLVE3D
2781 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
2782 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
2783 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
2784# endif
2785 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
2786 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
2787 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
2788# endif
2789# ifdef ADJUST_WSTRESS
2790 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
2791 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
2792# endif
2793# ifdef SOLVE3D
2794# ifdef ADJUST_STFLUX
2795 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
2796# endif
2797 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
2798 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
2799 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
2800# if defined WEAK_CONSTRAINT && defined TIME_CONV
2801 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
2802 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
2803# endif
2804# else
2805 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
2806 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
2807# endif
2808 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
2809# ifdef ADJUST_BOUNDARY
2810# ifdef SOLVE3D
2811 real(r8), intent(inout) :: nl_t_obc(LBij:,:,:,:,:,:)
2812 real(r8), intent(inout) :: nl_u_obc(LBij:,:,:,:,:)
2813 real(r8), intent(inout) :: nl_v_obc(LBij:,:,:,:,:)
2814# endif
2815 real(r8), intent(inout) :: nl_ubar_obc(LBij:,:,:,:)
2816 real(r8), intent(inout) :: nl_vbar_obc(LBij:,:,:,:)
2817 real(r8), intent(inout) :: nl_zeta_obc(LBij:,:,:,:)
2818# endif
2819# ifdef ADJUST_WSTRESS
2820 real(r8), intent(inout) :: nl_ustr(LBi:,LBj:,:,:)
2821 real(r8), intent(inout) :: nl_vstr(LBi:,LBj:,:,:)
2822# endif
2823# ifdef SOLVE3D
2824# ifdef ADJUST_STFLUX
2825 real(r8), intent(inout) :: nl_tflux(LBi:,LBj:,:,:,:)
2826# endif
2827 real(r8), intent(inout) :: nl_t(LBi:,LBj:,:,:,:)
2828 real(r8), intent(inout) :: nl_u(LBi:,LBj:,:,:)
2829 real(r8), intent(inout) :: nl_v(LBi:,LBj:,:,:)
2830# if defined WEAK_CONSTRAINT && defined TIME_CONV
2831 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
2832 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
2833# endif
2834# else
2835 real(r8), intent(inout) :: nl_ubar(LBi:,LBj:,:)
2836 real(r8), intent(inout) :: nl_vbar(LBi:,LBj:,:)
2837# endif
2838 real(r8), intent(inout) :: nl_zeta(LBi:,LBj:,:)
2839
2840# else
2841
2842# ifdef MASKING
2843 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
2844 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
2845 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
2846# endif
2847# ifdef ADJUST_BOUNDARY
2848# ifdef SOLVE3D
2849 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
2850 & Nbrec(ng),2,NT(ng))
2851 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2852 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2853# endif
2854 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2855 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2856 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2857# endif
2858# ifdef ADJUST_WSTRESS
2859 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2860 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2861# endif
2862# ifdef SOLVE3D
2863# ifdef ADJUST_STFLUX
2864 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
2865 & Nfrec(ng),2,NT(ng))
2866# endif
2867 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2868 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
2869 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
2870# if defined WEAK_CONSTRAINT && defined TIME_CONV
2871 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
2872 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
2873# endif
2874# else
2875 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
2876 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
2877# endif
2878 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
2879# ifdef ADJUST_BOUNDARY
2880# ifdef SOLVE3D
2881 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
2882 & Nbrec(ng),2,NT(ng))
2883 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2884 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2885# endif
2886 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2887 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2888 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2889# endif
2890# ifdef ADJUST_WSTRESS
2891 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2892 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2893# endif
2894# ifdef SOLVE3D
2895# ifdef ADJUST_STFLUX
2896 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
2897 & Nfrec(ng),2,NT(ng))
2898# endif
2899 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2900 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
2901 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
2902# if defined WEAK_CONSTRAINT && defined TIME_CONV
2903 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
2904 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
2905# endif
2906# else
2907 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
2908 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
2909# endif
2910 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
2911# ifdef ADJUST_BOUNDARY
2912# ifdef SOLVE3D
2913 real(r8), intent(inout) :: nl_t_obc(LBij:UBij,N(ng),4, &
2914 & Nbrec(ng),2,NT(ng))
2915 real(r8), intent(inout) :: nl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2916 real(r8), intent(inout) :: nl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2917# endif
2918 real(r8), intent(inout) :: nl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2919 real(r8), intent(inout) :: nl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2920 real(r8), intent(inout) :: nl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2921# endif
2922# ifdef ADJUST_WSTRESS
2923 real(r8), intent(inout) :: nl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2924 real(r8), intent(inout) :: nl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2925# endif
2926# ifdef SOLVE3D
2927# ifdef ADJUST_STFLUX
2928 real(r8), intent(inout) :: nl_tflux(LBi:UBi,LBj:UBj, &
2929 & Nfrec(ng),2,NT(ng))
2930# endif
2931 real(r8), intent(inout) :: nl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2932 real(r8), intent(inout) :: nl_u(LBi:UBi,LBj:UBj,N(ng),2)
2933 real(r8), intent(inout) :: nl_v(LBi:UBi,LBj:UBj,N(ng),2)
2934# if defined WEAK_CONSTRAINT && defined TIME_CONV
2935 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
2936 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
2937# endif
2938# else
2939 real(r8), intent(inout) :: nl_ubar(LBi:UBi,LBj:UBj,:)
2940 real(r8), intent(inout) :: nl_vbar(LBi:UBi,LBj:UBj,:)
2941# endif
2942 real(r8), intent(inout) :: nl_zeta(LBi:UBi,LBj:UBj,:)
2943# endif
2944
2945
2946
2947 integer :: i, j, k, lstr
2948 integer :: ib, ir, it, ivec, Ltmp1, Ltmp2, rec
2949
2950 real(r8) :: fac, fac1, fac2, zbet
2951
2952 real(r8), dimension(0:NstateVar(ng)) :: dot
2953 real(r8), dimension(1:Ninner) :: DotProd
2954
2955 real(r8), dimension(Ninner) :: zu, zgam
2956
2957 character (len=256) :: ncname
2958
2959 character (len=*), parameter :: MyFile = &
2960 & __FILE__//", analysis_error"
2961
2962# include "set_bounds.h"
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974 ltmp1=1
2975 ltmp2=2
2976
2977
2978
2979
2980
2981 ncname=hss(ng)%name
2982 DO ivec=1,ninner
2983 rec=ivec
2984
2985
2986
2987
2988 CALL state_read (ng, tile, model, hss(ng)%IOtype, &
2989 & lbi, ubi, lbj, ubj, lbij, ubij, &
2990 & ltmp1, rec, &
2991 & 0, hss(ng)%ncid, ncname, &
2992# ifdef MASKING
2993 & rmask, umask, vmask, &
2994# endif
2995# ifdef ADJUST_BOUNDARY
2996# ifdef SOLVE3D
2997 & nl_t_obc, nl_u_obc, nl_v_obc, &
2998# endif
2999 & nl_ubar_obc, nl_vbar_obc, &
3000 & nl_zeta_obc, &
3001# endif
3002# ifdef ADJUST_WSTRESS
3003 & nl_ustr, nl_vstr, &
3004# endif
3005# ifdef SOLVE3D
3006# ifdef ADJUST_STFLUX
3007 & nl_tflux, &
3008# endif
3009 & nl_t, nl_u, nl_v, &
3010# else
3011 & nl_ubar, nl_vbar, &
3012# endif
3013 & nl_zeta)
3014
3015
3016
3017 CALL state_dotprod (ng, tile, model, &
3018 & lbi, ubi, lbj, ubj, lbij, ubij, &
3019 & nstatevar(ng), dot(0:), &
3020# ifdef MASKING
3021 & rmask, umask, vmask, &
3022# endif
3023# ifdef ADJUST_BOUNDARY
3024# ifdef SOLVE3D
3025 & ad_t_obc(:,:,:,:,lnew,:), &
3026 & nl_t_obc(:,:,:,:,ltmp1,:), &
3027 & ad_u_obc(:,:,:,:,lnew), &
3028 & nl_u_obc(:,:,:,:,ltmp1), &
3029 & ad_v_obc(:,:,:,:,lnew), &
3030 & nl_v_obc(:,:,:,:,ltmp1), &
3031# endif
3032 & ad_ubar_obc(:,:,:,lnew), &
3033 & nl_ubar_obc(:,:,:,ltmp1), &
3034 & ad_vbar_obc(:,:,:,lnew), &
3035 & nl_vbar_obc(:,:,:,ltmp1), &
3036 & ad_zeta_obc(:,:,:,lnew), &
3037 & nl_zeta_obc(:,:,:,ltmp1), &
3038# endif
3039# ifdef ADJUST_WSTRESS
3040 & ad_ustr(:,:,:,lnew), nl_ustr(:,:,:,ltmp1), &
3041 & ad_vstr(:,:,:,lnew), nl_vstr(:,:,:,ltmp1), &
3042# endif
3043# ifdef SOLVE3D
3044# ifdef ADJUST_STFLUX
3045 & ad_tflux(:,:,:,lnew,:), &
3046 & nl_tflux(:,:,:,ltmp1,:), &
3047# endif
3048 & ad_t(:,:,:,lnew,:), nl_t(:,:,:,ltmp1,:), &
3049 & ad_u(:,:,:,lnew), nl_u(:,:,:,ltmp1), &
3050 & ad_v(:,:,:,lnew), nl_v(:,:,:,ltmp1), &
3051# else
3052 & ad_ubar(:,:,lnew), nl_ubar(:,:,ltmp1), &
3053 & ad_vbar(:,:,lnew), nl_vbar(:,:,ltmp1), &
3054# endif
3055 & ad_zeta(:,:,lnew), nl_zeta(:,:,ltmp1))
3056
3057 dotprod(ivec)=dot(0)
3058 END DO
3059
3060
3061
3062
3063 zbet=cg_delta(1,outloop)
3064 zu(1)=dotprod(1)/zbet
3065 DO ivec=2,ninner
3066 zgam(ivec)=cg_beta(ivec,outloop)/zbet
3067 zbet=cg_delta(ivec,outloop)-cg_beta(ivec,outloop)*zgam(ivec)
3068 zu(ivec)=(dotprod(ivec)-cg_beta(ivec,outloop)* &
3069 & zu(ivec-1))/zbet
3070 END DO
3071
3072 DO ivec=ninner-1,1,-1
3073 zu(ivec)=zu(ivec)-zgam(ivec+1)*zu(ivec+1)
3074 END DO
3075
3076
3077
3078
3079
3080
3081
3082 fac=0.0_r8
3083
3084 CALL state_initialize (ng, tile, &
3085 & lbi, ubi, lbj, ubj, lbij, ubij, &
3086 & ltmp2, fac, &
3087# ifdef MASKING
3088 & rmask, umask, vmask, &
3089# endif
3090# ifdef ADJUST_BOUNDARY
3091# ifdef SOLVE3D
3092 & nl_t_obc, nl_u_obc, nl_v_obc, &
3093# endif
3094 & nl_ubar_obc, nl_vbar_obc, &
3095 & nl_zeta_obc, &
3096# endif
3097# ifdef ADJUST_WSTRESS
3098 & nl_ustr, nl_vstr, &
3099# endif
3100# ifdef SOLVE3D
3101# ifdef ADJUST_STFLUX
3102 & nl_tflux, &
3103# endif
3104 & nl_t, nl_u, nl_v, &
3105# else
3106 & nl_ubar, nl_vbar, &
3107# endif
3108 & nl_zeta)
3109
3110 ncname=hss(ng)%name
3111 DO ivec=1,ninner
3112 rec=ivec
3113
3114
3115
3116
3117 CALL state_read (ng, tile, model, hss(ng)%IOtype, &
3118 & lbi, ubi, lbj, ubj, lbij, ubij, &
3119 & ltmp1, rec, &
3120 & 0, hss(ng)%ncid, ncname, &
3121# ifdef MASKING
3122 & rmask, umask, vmask, &
3123# endif
3124# ifdef ADJUST_BOUNDARY
3125# ifdef SOLVE3D
3126 & nl_t_obc, nl_u_obc, nl_v_obc, &
3127# endif
3128 & nl_ubar_obc, nl_vbar_obc, &
3129 & nl_zeta_obc, &
3130# endif
3131# ifdef ADJUST_WSTRESS
3132 & nl_ustr, nl_vstr, &
3133# endif
3134# ifdef SOLVE3D
3135# ifdef ADJUST_STFLUX
3136 & nl_tflux, &
3137# endif
3138 & nl_t, nl_u, nl_v, &
3139# else
3140 & nl_ubar, nl_vbar, &
3141# endif
3142 & nl_zeta)
3143
3144
3145
3146
3147
3148 fac1=1.0_r8
3149 fac2=zu(ivec)
3150
3151 CALL state_addition (ng, tile, &
3152 & lbi, ubi, lbj, ubj, lbij, ubij, &
3153 & ltmp2, ltmp1, ltmp2, fac1, fac2, &
3154# ifdef MASKING
3155 & rmask, umask, vmask, &
3156# endif
3157# ifdef ADJUST_BOUNDARY
3158# ifdef SOLVE3D
3159 & nl_t_obc, nl_t_obc, &
3160 & nl_u_obc, nl_u_obc, &
3161 & nl_v_obc, nl_v_obc, &
3162# endif
3163 & nl_ubar_obc, nl_ubar_obc, &
3164 & nl_vbar_obc, nl_vbar_obc, &
3165 & nl_zeta_obc, nl_zeta_obc, &
3166# endif
3167# ifdef ADJUST_WSTRESS
3168 & nl_ustr, nl_ustr, &
3169 & nl_vstr, nl_vstr, &
3170# endif
3171# ifdef SOLVE3D
3172# ifdef ADJUST_STFLUX
3173 & nl_tflux, nl_tflux, &
3174# endif
3175 & nl_t, nl_t, &
3176 & nl_u, nl_u, &
3177 & nl_v, nl_v, &
3178# if defined WEAK_CONSTRAINT && defined TIME_CONV
3179 & nl_ubar, nl_ubar, &
3180 & nl_vbar, nl_vbar, &
3181# endif
3182# else
3183 & nl_ubar, nl_ubar, &
3184 & nl_vbar, nl_vbar, &
3185# endif
3186 & nl_zeta, nl_zeta)
3187 END DO
3188
3189
3190
3191 CALL state_copy (ng, tile, &
3192 & lbi, ubi, lbj, ubj, lbij, ubij, &
3193 & ltmp2, lnew, &
3194# ifdef ADJUST_BOUNDARY
3195# ifdef SOLVE3D
3196 & ad_t_obc, nl_t_obc, &
3197 & ad_u_obc, nl_u_obc, &
3198 & ad_v_obc, nl_v_obc, &
3199# endif
3200 & ad_ubar_obc, nl_ubar_obc, &
3201 & ad_vbar_obc, nl_vbar_obc, &
3202 & ad_zeta_obc, nl_zeta_obc, &
3203# endif
3204# ifdef ADJUST_WSTRESS
3205 & ad_ustr, nl_ustr, &
3206 & ad_vstr, nl_vstr, &
3207# endif
3208# ifdef SOLVE3D
3209# ifdef ADJUST_STFLUX
3210 & ad_tflux, nl_tflux, &
3211# endif
3212 & ad_t, nl_t, &
3213 & ad_u, nl_u, &
3214 & ad_v, nl_v, &
3215# if defined WEAK_CONSTRAINT && defined TIME_CONV
3216 & ad_ubar, nl_ubar, &
3217 & ad_vbar, nl_vbar, &
3218# endif
3219# else
3220 & ad_ubar, nl_ubar, &
3221 & ad_vbar, nl_vbar, &
3222# endif
3223 & ad_zeta, nl_zeta)
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233 DO j=jstrt,jendt
3234 DO i=istrt,iendt
3235 ad_zeta(i,j,lnew)=tl_zeta(i,j,lnew)-ad_zeta(i,j,lnew)
3236# ifdef MASKING
3237 ad_zeta(i,j,lnew)=ad_zeta(i,j,lnew)*rmask(i,j)
3238# endif
3239 END DO
3240 END DO
3241
3242# ifdef ADJUST_BOUNDARY
3243
3244
3245
3246 IF (any(lobc(:,isfsur,ng))) THEN
3247 DO ir=1,nbrec(ng)
3248 IF ((lobc(iwest,isfsur,ng)).and. &
3249 & domain(ng)%Western_Edge(tile)) THEN
3250 ib=iwest
3251 DO j=jstr,jend
3252 ad_zeta_obc(j,ib,ir,lnew)=tl_zeta_obc(j,ib,ir,lnew)- &
3253 & ad_zeta_obc(j,ib,ir,lnew)
3254# ifdef MASKING
3255 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)* &
3256 & rmask(istr-1,j)
3257# endif
3258 END DO
3259 END IF
3260 IF ((lobc(ieast,isfsur,ng)).and. &
3261 & domain(ng)%Eastern_Edge(tile)) THEN
3262 ib=ieast
3263 DO j=jstr,jend
3264 ad_zeta_obc(j,ib,ir,lnew)=tl_zeta_obc(j,ib,ir,lnew)- &
3265 & ad_zeta_obc(j,ib,ir,lnew)
3266# ifdef MASKING
3267 ad_zeta_obc(j,ib,ir,lnew)=ad_zeta_obc(j,ib,ir,lnew)* &
3268 & rmask(iend+1,j)
3269# endif
3270 END DO
3271 END IF
3272 IF ((lobc(isouth,isfsur,ng)).and. &
3273 & domain(ng)%Southern_Edge(tile)) THEN
3274 ib=isouth
3275 DO i=istr,iend
3276 ad_zeta_obc(i,ib,ir,lnew)=tl_zeta_obc(i,ib,ir,lnew)- &
3277 & ad_zeta_obc(i,ib,ir,lnew)
3278# ifdef MASKING
3279 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)* &
3280 & rmask(i,jstr-1)
3281# endif
3282 END DO
3283 END IF
3284 IF ((lobc(inorth,isfsur,ng)).and. &
3285 & domain(ng)%Northern_Edge(tile)) THEN
3286 ib=inorth
3287 DO i=istr,iend
3288 ad_zeta_obc(i,ib,ir,lnew)=tl_zeta_obc(i,ib,ir,lnew)- &
3289 & ad_zeta_obc(i,ib,ir,lnew)
3290# ifdef MASKING
3291 ad_zeta_obc(i,ib,ir,lnew)=ad_zeta_obc(i,ib,ir,lnew)* &
3292 & rmask(i,jend+1)
3293# endif
3294 END DO
3295 END IF
3296 END DO
3297 END IF
3298# endif
3299
3300# ifndef SOLVE3D
3301
3302
3303
3304 DO j=jstrt,jendt
3305 DO i=istrp,iendt
3306 ad_ubar(i,j,lnew)=tl_ubar(i,j,lnew)-ad_ubar(i,j,lnew)
3307# ifdef MASKING
3308 ad_ubar(i,j,lnew)=ad_ubar(i,j,lnew)*umask(i,j)
3309# endif
3310 END DO
3311 END DO
3312# endif
3313
3314# ifdef ADJUST_BOUNDARY
3315
3316
3317
3318 IF (any(lobc(:,isubar,ng))) THEN
3319 DO ir=1,nbrec(ng)
3320 IF ((lobc(iwest,isubar,ng)).and. &
3321 & domain(ng)%Western_Edge(tile)) THEN
3322 ib=iwest
3323 DO j=jstr,jend
3324 ad_ubar_obc(j,ib,ir,lnew)=tl_ubar_obc(j,ib,ir,lnew)- &
3325 & ad_ubar_obc(j,ib,ir,lnew)
3326# ifdef MASKING
3327 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)* &
3328 & umask(istr,j)
3329# endif
3330 END DO
3331 END IF
3332 IF ((lobc(ieast,isubar,ng)).and. &
3333 & domain(ng)%Eastern_Edge(tile)) THEN
3334 ib=ieast
3335 DO j=jstr,jend
3336 ad_ubar_obc(j,ib,ir,lnew)=tl_ubar_obc(j,ib,ir,lnew)- &
3337 & ad_ubar_obc(j,ib,ir,lnew)
3338# ifdef MASKING
3339 ad_ubar_obc(j,ib,ir,lnew)=ad_ubar_obc(j,ib,ir,lnew)* &
3340 & umask(iend+1,j)
3341# endif
3342 END DO
3343 END IF
3344 IF ((lobc(isouth,isubar,ng)).and. &
3345 & domain(ng)%Southern_Edge(tile)) THEN
3346 ib=isouth
3347 DO i=istru,iend
3348 ad_ubar_obc(i,ib,ir,lnew)=tl_ubar_obc(i,ib,ir,lnew)- &
3349 & ad_ubar_obc(i,ib,ir,lnew)
3350# ifdef MASKING
3351 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)* &
3352 & umask(i,jstr-1)
3353# endif
3354 END DO
3355 END IF
3356 IF ((lobc(inorth,isubar,ng)).and. &
3357 & domain(ng)%Northern_Edge(tile)) THEN
3358 ib=inorth
3359 DO i=istru,iend
3360 ad_ubar_obc(i,ib,ir,lnew)=tl_ubar_obc(i,ib,ir,lnew)- &
3361 & ad_ubar_obc(i,ib,ir,lnew)
3362# ifdef MASKING
3363 ad_ubar_obc(i,ib,ir,lnew)=ad_ubar_obc(i,ib,ir,lnew)* &
3364 & umask(i,jend+1)
3365# endif
3366 END DO
3367 END IF
3368 END DO
3369 END IF
3370# endif
3371
3372# ifndef SOLVE3D
3373
3374
3375
3376 DO j=jstrp,jendt
3377 DO i=istrt,iendt
3378 ad_vbar(i,j,lnew)=tl_vbar(i,j,lnew)-ad_vbar(i,j,lnew)
3379# ifdef MASKING
3380 ad_vbar(i,j,lnew)=ad_vbar(i,j,lnew)*vmask(i,j)
3381# endif
3382 END DO
3383 END DO
3384# endif
3385
3386# ifdef ADJUST_BOUNDARY
3387
3388
3389
3390 IF (any(lobc(:,isvbar,ng))) THEN
3391 DO ir=1,nbrec(ng)
3392 IF ((lobc(iwest,isvbar,ng)).and. &
3393 & domain(ng)%Western_Edge(tile)) THEN
3394 ib=iwest
3395 DO j=jstrv,jend
3396 ad_vbar_obc(j,ib,ir,lnew)=tl_vbar_obc(j,ib,ir,lnew)- &
3397 & ad_vbar_obc(j,ib,ir,lnew)
3398# ifdef MASKING
3399 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)* &
3400 & vmask(istr-1,j)
3401# endif
3402 END DO
3403 END IF
3404 IF ((lobc(ieast,isvbar,ng)).and. &
3405 & domain(ng)%Eastern_Edge(tile)) THEN
3406 ib=ieast
3407 DO j=jstrv,jend
3408 ad_vbar_obc(j,ib,ir,lnew)=tl_vbar_obc(j,ib,ir,lnew)- &
3409 & ad_vbar_obc(j,ib,ir,lnew)
3410# ifdef MASKING
3411 ad_vbar_obc(j,ib,ir,lnew)=ad_vbar_obc(j,ib,ir,lnew)* &
3412 & vmask(iend+1,j)
3413# endif
3414 END DO
3415 END IF
3416 IF ((lobc(isouth,isvbar,ng)).and. &
3417 & domain(ng)%Southern_Edge(tile)) THEN
3418 ib=isouth
3419 DO i=istr,iend
3420 ad_vbar_obc(i,ib,ir,lnew)=tl_vbar_obc(i,ib,ir,lnew)- &
3421 & ad_vbar_obc(i,ib,ir,lnew)
3422# ifdef MASKING
3423 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)* &
3424 & vmask(i,jstr)
3425# endif
3426 END DO
3427 END IF
3428 IF ((lobc(inorth,isvbar,ng)).and. &
3429 & domain(ng)%Northern_Edge(tile)) THEN
3430 ib=inorth
3431 DO i=istr,iend
3432 ad_vbar_obc(i,ib,ir,lnew)=tl_vbar_obc(i,ib,ir,lnew)- &
3433 & ad_vbar_obc(i,ib,ir,lnew)
3434# ifdef MASKING
3435 ad_vbar_obc(i,ib,ir,lnew)=ad_vbar_obc(i,ib,ir,lnew)* &
3436 & vmask(i,jend+1)
3437# endif
3438 END DO
3439 END IF
3440 END DO
3441 END IF
3442# endif
3443
3444# ifdef ADJUST_WSTRESS
3445
3446
3447
3448 DO ir=1,nfrec(ng)
3449 DO j=jstrt,jendt
3450 DO i=istrp,iendt
3451 ad_ustr(i,j,ir,lnew)=tl_ustr(i,j,ir,lnew)- &
3452 & ad_ustr(i,j,ir,lnew)
3453# ifdef MASKING
3454 ad_ustr(i,j,ir,lnew)=ad_ustr(i,j,ir,lnew)*umask(i,j)
3455# endif
3456 END DO
3457 END DO
3458 DO j=jstrp,jendt
3459 DO i=istrt,iendt
3460 ad_vstr(i,j,ir,lnew)=tl_vstr(i,j,ir,lnew)- &
3461 & ad_vstr(i,j,ir,lnew)
3462# ifdef MASKING
3463 ad_vstr(i,j,ir,lnew)=ad_vstr(i,j,ir,lnew)*vmask(i,j)
3464# endif
3465 END DO
3466 END DO
3467 END DO
3468# endif
3469
3470# ifdef SOLVE3D
3471
3472
3473
3474 DO k=1,n(ng)
3475 DO j=jstrt,jendt
3476 DO i=istrp,iendt
3477 ad_u(i,j,k,lnew)=tl_u(i,j,k,lnew)-ad_u(i,j,k,lnew)
3478# ifdef MASKING
3479 ad_u(i,j,k,lnew)=ad_u(i,j,k,lnew)*umask(i,j)
3480# endif
3481 END DO
3482 END DO
3483 END DO
3484
3485# ifdef ADJUST_BOUNDARY
3486
3487
3488
3489 IF (any(lobc(:,isuvel,ng))) THEN
3490 DO ir=1,nbrec(ng)
3491 IF ((lobc(iwest,isuvel,ng)).and. &
3492 & domain(ng)%Western_Edge(tile)) THEN
3493 ib=iwest
3494 DO k=1,n(ng)
3495 DO j=jstr,jend
3496 ad_u_obc(j,k,ib,ir,lnew)=tl_u_obc(j,k,ib,ir,lnew)- &
3497 & ad_u_obc(j,k,ib,ir,lnew)
3498# ifdef MASKING
3499 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)* &
3500 & umask(istr,j)
3501# endif
3502 END DO
3503 END DO
3504 END IF
3505 IF ((lobc(ieast,isuvel,ng)).and. &
3506 & domain(ng)%Eastern_Edge(tile)) THEN
3507 ib=ieast
3508 DO k=1,n(ng)
3509 DO j=jstr,jend
3510 ad_u_obc(j,k,ib,ir,lnew)=tl_u_obc(j,k,ib,ir,lnew)- &
3511 & ad_u_obc(j,k,ib,ir,lnew)
3512# ifdef MASKING
3513 ad_u_obc(j,k,ib,ir,lnew)=ad_u_obc(j,k,ib,ir,lnew)* &
3514 & umask(iend+1,j)
3515# endif
3516 END DO
3517 END DO
3518 END IF
3519 IF ((lobc(isouth,isuvel,ng)).and. &
3520 & domain(ng)%Southern_Edge(tile)) THEN
3521 ib=isouth
3522 DO k=1,n(ng)
3523 DO i=istru,iend
3524 ad_u_obc(i,k,ib,ir,lnew)=tl_u_obc(i,k,ib,ir,lnew)- &
3525 & ad_u_obc(i,k,ib,ir,lnew)
3526# ifdef MASKING
3527 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)* &
3528 & umask(i,jstr-1)
3529# endif
3530 END DO
3531 END DO
3532 END IF
3533 IF ((lobc(inorth,isuvel,ng)).and. &
3534 & domain(ng)%Northern_Edge(tile)) THEN
3535 ib=inorth
3536 DO k=1,n(ng)
3537 DO i=istru,iend
3538 ad_u_obc(i,k,ib,ir,lnew)=tl_u_obc(i,k,ib,ir,lnew)- &
3539 & ad_u_obc(i,k,ib,ir,lnew)
3540# ifdef MASKING
3541 ad_u_obc(i,k,ib,ir,lnew)=ad_u_obc(i,k,ib,ir,lnew)* &
3542 & umask(i,jend+1)
3543# endif
3544 END DO
3545 END DO
3546 END IF
3547 END DO
3548 END IF
3549# endif
3550
3551
3552
3553 DO k=1,n(ng)
3554 DO j=jstrp,jendt
3555 DO i=istrt,iendt
3556 ad_v(i,j,k,lnew)=tl_v(i,j,k,lnew)-ad_v(i,j,k,lnew)
3557# ifdef MASKING
3558 ad_v(i,j,k,lnew)=ad_v(i,j,k,lnew)*vmask(i,j)
3559# endif
3560 END DO
3561 END DO
3562 END DO
3563
3564# ifdef ADJUST_BOUNDARY
3565
3566
3567
3568 IF (any(lobc(:,isvvel,ng))) THEN
3569 DO ir=1,nbrec(ng)
3570 IF ((lobc(iwest,isvvel,ng)).and. &
3571 & domain(ng)%Western_Edge(tile)) THEN
3572 ib=iwest
3573 DO k=1,n(ng)
3574 DO j=jstrv,jend
3575 ad_v_obc(j,k,ib,ir,lnew)=tl_v_obc(j,k,ib,ir,lnew)- &
3576 & ad_v_obc(j,k,ib,ir,lnew)
3577# ifdef MASKING
3578 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)* &
3579 & vmask(istr-1,j)
3580# endif
3581 END DO
3582 END DO
3583 END IF
3584 IF ((lobc(ieast,isvvel,ng)).and. &
3585 & domain(ng)%Eastern_Edge(tile)) THEN
3586 ib=ieast
3587 DO k=1,n(ng)
3588 DO j=jstrv,jend
3589 ad_v_obc(j,k,ib,ir,lnew)=tl_v_obc(j,k,ib,ir,lnew)- &
3590 & ad_v_obc(j,k,ib,ir,lnew)
3591# ifdef MASKING
3592 ad_v_obc(j,k,ib,ir,lnew)=ad_v_obc(j,k,ib,ir,lnew)* &
3593 & vmask(iend+1,j)
3594# endif
3595 END DO
3596 END DO
3597 END IF
3598 IF ((lobc(isouth,isvvel,ng)).and. &
3599 & domain(ng)%Southern_Edge(tile)) THEN
3600 ib=isouth
3601 DO k=1,n(ng)
3602 DO i=istr,iend
3603 ad_v_obc(i,k,ib,ir,lnew)=tl_v_obc(i,k,ib,ir,lnew)- &
3604 & ad_v_obc(i,k,ib,ir,lnew)
3605# ifdef MASKING
3606 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)* &
3607 & vmask(i,jstr)
3608# endif
3609 END DO
3610 END DO
3611 END IF
3612 IF ((lobc(inorth,isvvel,ng)).and. &
3613 & domain(ng)%Northern_Edge(tile)) THEN
3614 ib=inorth
3615 DO k=1,n(ng)
3616 DO i=istr,iend
3617 ad_v_obc(i,k,ib,ir,lnew)=tl_v_obc(i,k,ib,ir,lnew)- &
3618 & ad_v_obc(i,k,ib,ir,lnew)
3619# ifdef MASKING
3620 ad_v_obc(i,k,ib,ir,lnew)=ad_v_obc(i,k,ib,ir,lnew)* &
3621 & vmask(i,jend+1)
3622# endif
3623 END DO
3624 END DO
3625 END IF
3626 END DO
3627 END IF
3628# endif
3629
3630
3631
3632 DO it=1,nt(ng)
3633 DO k=1,n(ng)
3634 DO j=jstrt,jendt
3635 DO i=istrt,iendt
3636 ad_t(i,j,k,lnew,it)=tl_t(i,j,k,lnew,it)- &
3637 & ad_t(i,j,k,lnew,it)
3638# ifdef MASKING
3639 ad_t(i,j,k,lnew,it)=ad_t(i,j,k,lnew,it)*rmask(i,j)
3640# endif
3641 END DO
3642 END DO
3643 END DO
3644 END DO
3645
3646# ifdef ADJUST_BOUNDARY
3647
3648
3649
3650 DO it=1,nt(ng)
3651 IF (any(lobc(:,istvar(it),ng))) THEN
3652 DO ir=1,nbrec(ng)
3653 IF ((lobc(iwest,istvar(it),ng)).and. &
3654 & domain(ng)%Western_Edge(tile)) THEN
3655 ib=iwest
3656 DO k=1,n(ng)
3657 DO j=jstr,jend
3658 ad_t_obc(j,k,ib,ir,lnew,it)= &
3659 & tl_t_obc(j,k,ib,ir,lnew,it)- &
3660 & ad_t_obc(j,k,ib,ir,lnew,it)
3661# ifdef MASKING
3662 ad_t_obc(j,k,ib,ir,lnew,it)= &
3663 & ad_t_obc(j,k,ib,ir,lnew,it)*rmask(istr-1,j)
3664# endif
3665 END DO
3666 END DO
3667 END IF
3668 IF ((lobc(ieast,istvar(it),ng)).and. &
3669 & domain(ng)%Eastern_Edge(tile)) THEN
3670 ib=ieast
3671 DO k=1,n(ng)
3672 DO j=jstr,jend
3673 ad_t_obc(j,k,ib,ir,lnew,it)= &
3674 & tl_t_obc(j,k,ib,ir,lnew,it)- &
3675 & ad_t_obc(j,k,ib,ir,lnew,it)
3676# ifdef MASKING
3677 ad_t_obc(j,k,ib,ir,lnew,it)= &
3678 & ad_t_obc(j,k,ib,ir,lnew,it)*rmask(iend+1,j)
3679# endif
3680 END DO
3681 END DO
3682 END IF
3683 IF ((lobc(isouth,istvar(it),ng)).and. &
3684 & domain(ng)%Southern_Edge(tile)) THEN
3685 ib=isouth
3686 DO k=1,n(ng)
3687 DO i=istr,iend
3688 ad_t_obc(i,k,ib,ir,lnew,it)= &
3689 & tl_t_obc(i,k,ib,ir,lnew,it)- &
3690 & ad_t_obc(i,k,ib,ir,lnew,it)
3691# ifdef MASKING
3692 ad_t_obc(i,k,ib,ir,lnew,it)= &
3693 & ad_t_obc(i,k,ib,ir,lnew,it)*rmask(i,jstr-1)
3694# endif
3695 END DO
3696 END DO
3697 END IF
3698 IF ((lobc(inorth,istvar(it),ng)).and. &
3699 & domain(ng)%Northern_Edge(tile)) THEN
3700 ib=inorth
3701 DO k=1,n(ng)
3702 DO i=istr,iend
3703 ad_t_obc(i,k,ib,ir,lnew,it)= &
3704 & tl_t_obc(i,k,ib,ir,lnew,it)- &
3705 & ad_t_obc(i,k,ib,ir,lnew,it)
3706# ifdef MASKING
3707 ad_t_obc(i,k,ib,ir,lnew,it)= &
3708 & ad_t_obc(i,k,ib,ir,lnew,it)*rmask(i,jend+1)
3709# endif
3710 END DO
3711 END DO
3712 END IF
3713 END DO
3714 END IF
3715 END DO
3716# endif
3717
3718# ifdef ADJUST_STFLUX
3719
3720
3721
3722 DO it=1,nt(ng)
3723 IF (lstflux(it,ng)) THEN
3724 DO ir=1,nfrec(ng)
3725 DO j=jstrt,jendt
3726 DO i=istrt,iendt
3727 ad_tflux(i,j,ir,lnew,it)=tl_tflux(i,j,ir,lnew,it)- &
3728 & ad_tflux(i,j,ir,lnew,it)
3729# ifdef MASKING
3730 ad_tflux(i,j,ir,lnew,it)=ad_tflux(i,j,ir,lnew,it)* &
3731 & rmask(i,j)
3732# endif
3733 END DO
3734 END DO
3735 END DO
3736 END IF
3737 END DO
3738# endif
3739# endif
3740
3741
3742
3743
3744
3745
3746 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3747
3748
3749
3750
3751 CALL state_dotprod (ng, tile, model, &
3752 & lbi, ubi, lbj, ubj, lbij, ubij, &
3753 & nstatevar(ng), dot(0:), &
3754# ifdef MASKING
3755 & rmask, umask, vmask, &
3756# endif
3757# ifdef ADJUST_BOUNDARY
3758# ifdef SOLVE3D
3759 & ad_t_obc(:,:,:,:,lnew,:), &
3760 & tl_t_obc(:,:,:,:,lwrk,:), &
3761 & ad_u_obc(:,:,:,:,lnew), &
3762 & tl_u_obc(:,:,:,:,lwrk), &
3763 & ad_v_obc(:,:,:,:,lnew), &
3764 & tl_v_obc(:,:,:,:,lwrk), &
3765# endif
3766 & ad_ubar_obc(:,:,:,lnew), &
3767 & tl_ubar_obc(:,:,:,lwrk), &
3768 & ad_vbar_obc(:,:,:,lnew), &
3769 & tl_vbar_obc(:,:,:,lwrk), &
3770 & ad_zeta_obc(:,:,:,lnew), &
3771 & tl_zeta_obc(:,:,:,lwrk), &
3772# endif
3773# ifdef ADJUST_WSTRESS
3774 & ad_ustr(:,:,:,lnew), tl_ustr(:,:,:,lwrk), &
3775 & ad_vstr(:,:,:,lnew), tl_vstr(:,:,:,lwrk), &
3776# endif
3777# ifdef SOLVE3D
3778# ifdef ADJUST_STFLUX
3779 & ad_tflux(:,:,:,lnew,:), &
3780 & tl_tflux(:,:,:,lwrk,:), &
3781# endif
3782 & ad_t(:,:,:,lnew,:), tl_t(:,:,:,lwrk,:), &
3783 & ad_u(:,:,:,lnew), tl_u(:,:,:,lwrk), &
3784 & ad_v(:,:,:,lnew), tl_v(:,:,:,lwrk), &
3785# else
3786 & ad_ubar(:,:,lnew), tl_ubar(:,:,lwrk), &
3787 & ad_vbar(:,:,lnew), tl_vbar(:,:,lwrk), &
3788# endif
3789 & ad_zeta(:,:,lnew), tl_zeta(:,:,lwrk))
3790
3791 ae_delta(innloop,outloop)=dot(0)
3792
3793 RETURN