163
164
170
171# ifdef DISTRIBUTE
172
174# endif
175
176
177
178 integer, intent(in) :: ng, tile
179 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
180 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
181 integer, intent(in) :: Lsum
182
183# ifdef ASSUMED_SHAPE
184# ifdef MASKING
185 real(r8), intent(in) :: rmask(LBi:,LBj:)
186 real(r8), intent(in) :: umask(LBi:,LBj:)
187 real(r8), intent(in) :: vmask(LBi:,LBj:)
188# endif
189# ifdef ADJUST_BOUNDARY
190# ifdef SOLVE3D
191 real(r8), intent(in) :: tl_t_obc(LBij:,:,:,:,:,:)
192 real(r8), intent(in) :: tl_u_obc(LBij:,:,:,:,:)
193 real(r8), intent(in) :: tl_v_obc(LBij:,:,:,:,:)
194# endif
195 real(r8), intent(in) :: tl_ubar_obc(LBij:,:,:,:)
196 real(r8), intent(in) :: tl_vbar_obc(LBij:,:,:,:)
197 real(r8), intent(in) :: tl_zeta_obc(LBij:,:,:,:)
198# endif
199# ifdef ADJUST_WSTRESS
200 real(r8), intent(in) :: tl_ustr(LBi:,LBj:,:,:)
201 real(r8), intent(in) :: tl_vstr(LBi:,LBj:,:,:)
202# endif
203# ifdef SOLVE3D
204# ifdef ADJUST_STFLUX
205 real(r8), intent(in) :: tl_tflux(LBi:,LBj:,:,:,:)
206# endif
207 real(r8), intent(in) :: tl_t(LBi:,LBj:,:,:,:)
208 real(r8), intent(in) :: tl_u(LBi:,LBj:,:,:)
209 real(r8), intent(in) :: tl_v(LBi:,LBj:,:,:)
210# else
211 real(r8), intent(in) :: tl_ubar(LBi:,LBj:,:)
212 real(r8), intent(in) :: tl_vbar(LBi:,LBj:,:)
213# endif
214 real(r8), intent(in) :: tl_zeta(LBi:,LBj:,:)
215
216# else
217
218# ifdef MASKING
219 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
220 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
221 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
222# endif
223# ifdef ADJUST_BOUNDARY
224# ifdef SOLVE3D
225 real(r8), intent(in) :: tl_t_obc(LBij:UBij,N(ng),4, &
226 & Nbrec(ng),2,NT(ng))
227 real(r8), intent(in) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
228 real(r8), intent(in) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
229# endif
230 real(r8), intent(in) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
231 real(r8), intent(in) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
232 real(r8), intent(in) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
233# endif
234# ifdef ADJUST_WSTRESS
235 real(r8), intent(in) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
236 real(r8), intent(in) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
237# endif
238# ifdef SOLVE3D
239# ifdef ADJUST_STFLUX
240 real(r8), intent(in) :: tl_tflux(LBi:UBi,LBj:UBj, &
241 & Nfrec(ng),2,NT(ng))
242# endif
243 real(r8), intent(in) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
244 real(r8), intent(in) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
245 real(r8), intent(in) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
246# else
247 real(r8), intent(in) :: tl_ubar(LBi:UBi,LBj:UBj,:)
248 real(r8), intent(in) :: tl_vbar(LBi:UBi,LBj:UBj,:)
249# endif
250 real(r8), intent(in) :: tl_zeta(LBi:UBi,LBj:UBj,:)
251# endif
252
253
254
255 integer :: NSUB, i, ib, ir, j, k
256# ifdef SOLVE3D
257 integer :: itrc
258# endif
259
260 real(r8), dimension(0:NstateVar(ng)) :: my_BackCost
261
262 real(r8) :: cff1, cff2
263
264# ifdef DISTRIBUTE
265 character (len=3), dimension(0:NstateVar(ng)) :: op_handle
266# endif
267
268# include "set_bounds.h"
269
270
271
272
273
274
275
276
277
278
279
281 my_backcost(i)=0.0_r8
282 END DO
283
284
285
286 DO j=jstr,jend
287 DO i=istr,iend
288 cff1=tl_zeta(i,j,lsum)
289# ifdef MASKING
290 cff1=cff1*rmask(i,j)
291# endif
292 cff2=0.5_r8*cff1*cff1
293 my_backcost(0)=my_backcost(0)+cff2
295 END DO
296 END DO
297
298# ifdef ADJUST_BOUNDARY
299
300
301
305 &
domain(ng)%Western_Edge(tile))
THEN
307 DO j=jstr,jend
308 cff1=tl_zeta_obc(j,ib,ir,lsum)
309# ifdef MASKING
310 cff1=cff1*rmask(istr-1,j)
311# endif
312 cff2=0.5_r8*cff1*cff1
313 my_backcost(0)=my_backcost(0)+cff2
315 END DO
316 END IF
318 &
domain(ng)%Eastern_Edge(tile))
THEN
320 DO j=jstr,jend
321 cff1=tl_zeta_obc(j,ib,ir,lsum)
322# ifdef MASKING
323 cff1=cff1*rmask(iend+1,j)
324# endif
325 cff2=0.5_r8*cff1*cff1
326 my_backcost(0)=my_backcost(0)+cff2
328 END DO
329 END IF
331 &
domain(ng)%Southern_Edge(tile))
THEN
333 DO i=istr,iend
334 cff1=tl_zeta_obc(i,ib,ir,lsum)
335# ifdef MASKING
336 cff1=cff1*rmask(i,jstr-1)
337# endif
338 cff2=0.5_r8*cff1*cff1
339 my_backcost(0)=my_backcost(0)+cff2
341 END DO
342 END IF
344 &
domain(ng)%Northern_Edge(tile))
THEN
346 DO i=istr,iend
347 cff1=tl_zeta_obc(i,ib,ir,lsum)
348# ifdef MASKING
349 cff1=cff1*rmask(i,jend+1)
350# endif
351 cff2=0.5_r8*cff1*cff1
352 my_backcost(0)=my_backcost(0)+cff2
354 END DO
355 END IF
356 END DO
357 END IF
358# endif
359
360# ifndef SOLVE3D
361
362
363
364 DO j=jstr,jend
365 DO i=istru,iend
366 cff1=tl_ubar(i,j,lsum)
367# ifdef MASKING
368 cff1=cff1*umask(i,j)
369# endif
370 cff2=0.5_r8*cff1*cff1
371 my_backcost(0)=my_backcost(0)+cff2
373 END DO
374 END DO
375# endif
376
377# ifdef ADJUST_BOUNDARY
378
379
380
384 &
domain(ng)%Western_Edge(tile))
THEN
386 DO j=jstr,jend
387 cff1=tl_ubar_obc(j,ib,ir,lsum)
388# ifdef MASKING
389 cff1=cff1*umask(istr,j)
390# endif
391 cff2=0.5_r8*cff1*cff1
392 my_backcost(0)=my_backcost(0)+cff2
394 END DO
395 END IF
397 &
domain(ng)%Eastern_Edge(tile))
THEN
399 DO j=jstr,jend
400 cff1=tl_ubar_obc(j,ib,ir,lsum)
401# ifdef MASKING
402 cff1=cff1*umask(iend+1,j)
403# endif
404 cff2=0.5_r8*cff1*cff1
405 my_backcost(0)=my_backcost(0)+cff2
407 END DO
408 END IF
410 &
domain(ng)%Southern_Edge(tile))
THEN
412 DO i=istru,iend
413 cff1=tl_ubar_obc(i,ib,ir,lsum)
414# ifdef MASKING
415 cff1=cff1*umask(i,jstr-1)
416# endif
417 cff2=0.5_r8*cff1*cff1
418 my_backcost(0)=my_backcost(0)+cff2
420 END DO
421 END IF
423 &
domain(ng)%Northern_Edge(tile))
THEN
425 DO i=istru,iend
426 cff1=tl_ubar_obc(i,ib,ir,lsum)
427# ifdef MASKING
428 cff1=cff1*umask(i,jend+1)
429# endif
430 cff2=0.5_r8*cff1*cff1
431 my_backcost(0)=my_backcost(0)+cff2
433 END DO
434 END IF
435 END DO
436 END IF
437# endif
438
439# ifndef SOLVE3D
440
441
442
443 DO j=jstrv,jend
444 DO i=istr,iend
445 cff1=tl_vbar(i,j,lsum)
446# ifdef MASKING
447 cff1=cff1*vmask(i,j)
448# endif
449 cff2=0.5_r8*cff1*cff1
450 my_backcost(0)=my_backcost(0)+cff2
452 END DO
453 END DO
454# endif
455
456# ifdef ADJUST_BOUNDARY
457
458
459
463 &
domain(ng)%Western_Edge(tile))
THEN
465 DO j=jstrv,jend
466 cff1=tl_vbar_obc(j,ib,ir,lsum)
467# ifdef MASKING
468 cff1=cff1*vmask(istr-1,j)
469# endif
470 cff2=0.5_r8*cff1*cff1
471 my_backcost(0)=my_backcost(0)+cff2
473 END DO
474 END IF
476 &
domain(ng)%Eastern_Edge(tile))
THEN
478 DO j=jstrv,jend
479 cff1=tl_vbar_obc(j,ib,ir,lsum)
480# ifdef MASKING
481 cff1=cff1*vmask(iend+1,j)
482# endif
483 cff2=0.5_r8*cff1*cff1
484 my_backcost(0)=my_backcost(0)+cff2
486 END DO
487 END IF
489 &
domain(ng)%Southern_Edge(tile))
THEN
491 DO i=istr,iend
492 cff1=tl_vbar_obc(i,ib,ir,lsum)
493# ifdef MASKING
494 cff1=cff1*vmask(i,jstr)
495# endif
496 cff2=0.5_r8*cff1*cff1
497 my_backcost(0)=my_backcost(0)+cff2
499 END DO
500 END IF
502 &
domain(ng)%Northern_Edge(tile))
THEN
504 DO i=istr,iend
505 cff1=tl_vbar_obc(i,ib,ir,lsum)
506# ifdef MASKING
507 cff1=cff1*vmask(i,jend+1)
508# endif
509 cff2=0.5_r8*cff1*cff1
510 my_backcost(0)=my_backcost(0)+cff2
512 END DO
513 END IF
514 END DO
515 END IF
516# endif
517
518# ifdef ADJUST_WSTRESS
519
520
521
523 DO j=jstrr,jendr
524 DO i=istr,iendr
525 cff1=tl_ustr(i,j,ir,lsum)
526# ifdef MASKING
527 cff1=cff1*umask(i,j)
528# endif
529 cff2=0.5_r8*cff1*cff1
530 my_backcost(0)=my_backcost(0)+cff2
532 END DO
533 END DO
534 DO j=jstr,jendr
535 DO i=istrr,iendr
536 cff1=tl_vstr(i,j,ir,lsum)
537# ifdef MASKING
538 cff1=cff1*vmask(i,j)
539# endif
540 cff2=0.5_r8*cff1*cff1
541 my_backcost(0)=my_backcost(0)+cff2
543 END DO
544 END DO
545 END DO
546# endif
547
548# ifdef SOLVE3D
549
550
551
553 DO j=jstr,jend
554 DO i=istru,iend
555 cff1=tl_u(i,j,k,lsum)
556# ifdef MASKING
557 cff1=cff1*umask(i,j)
558# endif
559 cff2=0.5_r8*cff1*cff1
560 my_backcost(0)=my_backcost(0)+cff2
562 END DO
563 END DO
564 END DO
565
566# ifdef ADJUST_BOUNDARY
567
568
569
573 &
domain(ng)%Western_Edge(tile))
THEN
576 DO j=jstr,jend
577 cff1=tl_u_obc(j,k,ib,ir,lsum)
578# ifdef MASKING
579 cff1=cff1*umask(istr,j)
580# endif
581 cff2=0.5_r8*cff1*cff1
582 my_backcost(0)=my_backcost(0)+cff2
584 END DO
585 END DO
586 END IF
588 &
domain(ng)%Eastern_Edge(tile))
THEN
591 DO j=jstr,jend
592 cff1=tl_u_obc(j,k,ib,ir,lsum)
593# ifdef MASKING
594 cff1=cff1*umask(iend+1,j)
595# endif
596 cff2=0.5_r8*cff1*cff1
597 my_backcost(0)=my_backcost(0)+cff2
599 END DO
600 END DO
601 END IF
603 &
domain(ng)%Southern_Edge(tile))
THEN
606 DO i=istru,iend
607 cff1=tl_u_obc(i,k,ib,ir,lsum)
608# ifdef MASKING
609 cff1=cff1*umask(i,jstr-1)
610# endif
611 cff2=0.5_r8*cff1*cff1
612 my_backcost(0)=my_backcost(0)+cff2
614 END DO
615 END DO
616 END IF
618 &
domain(ng)%Northern_Edge(tile))
THEN
621 DO i=istru,iend
622 cff1=tl_u_obc(i,k,ib,ir,lsum)
623# ifdef MASKING
624 cff1=cff1*umask(i,jend+1)
625# endif
626 cff2=0.5_r8*cff1*cff1
627 my_backcost(0)=my_backcost(0)+cff2
629 END DO
630 END DO
631 END IF
632 END DO
633 END IF
634# endif
635
636
637
639 DO j=jstrv,jend
640 DO i=istr,iend
641 cff1=tl_v(i,j,k,lsum)
642# ifdef MASKING
643 cff1=cff1*vmask(i,j)
644# endif
645 cff2=0.5_r8*cff1*cff1
646 my_backcost(0)=my_backcost(0)+cff2
648 END DO
649 END DO
650 END DO
651
652# ifdef ADJUST_BOUNDARY
653
654
655
659 &
domain(ng)%Western_Edge(tile))
THEN
662 DO j=jstrv,jend
663 cff1=tl_v_obc(j,k,ib,ir,lsum)
664# ifdef MASKING
665 cff1=cff1*vmask(istr-1,j)
666# endif
667 cff2=0.5_r8*cff1*cff1
668 my_backcost(0)=my_backcost(0)+cff2
670 END DO
671 END DO
672 END IF
674 &
domain(ng)%Eastern_Edge(tile))
THEN
677 DO j=jstrv,jend
678 cff1=tl_v_obc(j,k,ib,ir,lsum)
679# ifdef MASKING
680 cff1=cff1*vmask(iend+1,j)
681# endif
682 cff2=0.5_r8*cff1*cff1
683 my_backcost(0)=my_backcost(0)+cff2
685 END DO
686 END DO
687 END IF
689 &
domain(ng)%Southern_Edge(tile))
THEN
692 DO i=istr,iend
693 cff1=tl_v_obc(i,k,ib,ir,lsum)
694# ifdef MASKING
695 cff1=cff1*vmask(i,jstr)
696# endif
697 cff2=0.5_r8*cff1*cff1
698 my_backcost(0)=my_backcost(0)+cff2
700 END DO
701 END DO
702 END IF
704 &
domain(ng)%Northern_Edge(tile))
THEN
707 DO i=istr,iend
708 cff1=tl_v_obc(i,k,ib,ir,lsum)
709# ifdef MASKING
710 cff1=cff1*vmask(i,jend+1)
711# endif
712 cff2=0.5_r8*cff1*cff1
713 my_backcost(0)=my_backcost(0)+cff2
715 END DO
716 END DO
717 END IF
718 END DO
719 END IF
720# endif
721
722
723
726 DO j=jstr,jend
727 DO i=istr,iend
728 cff1=tl_t(i,j,k,lsum,itrc)
729# ifdef MASKING
730 cff1=cff1*rmask(i,j)
731# endif
732 cff2=0.5_r8*cff1*cff1
733 my_backcost(0)=my_backcost(0)+cff2
734 my_backcost(
istvar(itrc))=my_backcost(
istvar(itrc))+cff2
735 END DO
736 END DO
737 END DO
738 END DO
739
740# ifdef ADJUST_BOUNDARY
741
742
743
748 &
domain(ng)%Western_Edge(tile))
THEN
751 DO j=jstr,jend
752 cff1=tl_t_obc(j,k,ib,ir,lsum,itrc)
753# ifdef MASKING
754 cff1=cff1*rmask(istr-1,j)
755# endif
756 cff2=0.5_r8*cff1*cff1
757 my_backcost(0)=my_backcost(0)+cff2
759 & cff2
760 END DO
761 END DO
762 END IF
764 &
domain(ng)%Eastern_Edge(tile))
THEN
767 DO j=jstr,jend
768 cff1=tl_t_obc(j,k,ib,ir,lsum,itrc)
769# ifdef MASKING
770 cff1=cff1*rmask(iend+1,j)
771# endif
772 cff2=0.5_r8*cff1*cff1
773 my_backcost(0)=my_backcost(0)+cff2
775 & cff2
776 END DO
777 END DO
778 END IF
780 &
domain(ng)%Southern_Edge(tile))
THEN
783 DO i=istr,iend
784 cff1=tl_t_obc(i,k,ib,ir,lsum,itrc)
785# ifdef MASKING
786 cff1=cff1*rmask(i,jstr-1)
787# endif
788 cff2=0.5_r8*cff1*cff1
789 my_backcost(0)=my_backcost(0)+cff2
791 & cff2
792 END DO
793 END DO
794 END IF
796 &
domain(ng)%Northern_Edge(tile))
THEN
799 DO i=istr,iend
800 cff1=tl_t_obc(i,k,ib,ir,lsum,itrc)
801# ifdef MASKING
802 cff1=cff1*rmask(i,jend+1)
803# endif
804 cff2=0.5_r8*cff1*cff1
805 my_backcost(0)=my_backcost(0)+cff2
807 & cff2
808 END DO
809 END DO
810 END IF
811 END DO
812 END IF
813 END DO
814# endif
815
816# ifdef ADJUST_STFLUX
817
818
819
823 DO j=jstrr,jendr
824 DO i=istrr,iendr
825 cff1=tl_tflux(i,j,ir,lsum,itrc)
826# ifdef MASKING
827 cff1=cff1*rmask(i,j)
828# endif
829 cff2=0.5_r8*cff1*cff1
830 my_backcost(0)=my_backcost(0)+cff2
831 my_backcost(
istsur(itrc))=my_backcost(
istsur(itrc))+cff2
832 END DO
833 END DO
834 END DO
835 END IF
836 END DO
837# endif
838# endif
839
840
841
842
843
844# ifdef DISTRIBUTE
845 nsub=1
846# else
847 IF (
domain(ng)%SouthWest_Corner(tile).and. &
848 &
domain(ng)%NorthEast_Corner(tile))
THEN
849 nsub=1
850 ELSE
852 END IF
853# endif
854
857 fourdvar(ng)%BackCost(i)=my_backcost(i)
858 END DO
859 ELSE
862 & my_backcost(i)
863 END DO
864 END IF
868# ifdef DISTRIBUTE
870 op_handle(i)='SUM'
871 END DO
873 &
fourdvar(ng)%BackCost(0:), op_handle(0:))
874# endif
875 END IF
876
877
878 RETURN
type(t_fourdvar), dimension(:), allocatable fourdvar
integer, dimension(:), allocatable nstatevar
integer, dimension(:), allocatable istvar
integer, dimension(:), allocatable istsur
integer, dimension(:), allocatable n
integer, dimension(:), allocatable ntilex
type(t_domain), dimension(:), allocatable domain
integer, dimension(:), allocatable ntilee
integer, dimension(:), allocatable nt
logical, dimension(:,:,:), allocatable lobc
logical, dimension(:,:), allocatable lstflux
integer, dimension(:), allocatable nfrec
integer, parameter isouth
integer, parameter inorth
integer, dimension(:), allocatable nbrec