-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathmod_hycom.F+97W
executable file
·3766 lines (3755 loc) · 124 KB
/
mod_hycom.F+97W
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#if defined(ROW_LAND)
#define SEA_P .true.
#define SEA_U .true.
#define SEA_V .true.
#elif defined(ROW_ALLSEA)
#define SEA_P allip(j).or.ip(i,j).ne.0
#define SEA_U alliu(j).or.iu(i,j).ne.0
#define SEA_V alliv(j).or.iv(i,j).ne.0
#else
#define SEA_P ip(i,j).ne.0
#define SEA_U iu(i,j).ne.0
#define SEA_V iv(i,j).ne.0
#endif
module mod_hycom
#if defined(USE_ESMF)
use ESMF_Mod ! ESMF Framework
#endif
use mod_xc ! HYCOM communication interface
use mod_cb_arrays ! HYCOM saved arrays
use mod_za ! HYCOM I/O interface
use mod_pipe ! HYCOM debugging interface
use mod_incupd ! HYCOM incremental update (for data assimilation)
use mod_floats ! HYCOM synthetic floats, drifters and moorings
use mod_tides ! HYCOM tides
use mod_archiv ! HYCOM archives
use mod_mean ! HYCOM mean archives
use mod_momtum ! HYCOM momentum
use mod_tsadvc ! HYCOM scalar advection
#if defined(STOKES)
use mod_stokes ! HYCOM Stokes drift
#endif
#if defined(USE_CCSM3)
use ccsm3, only : ccsm3_setup_coupling_env ! ccsm3 ocean
use ccsm3_exit ! ccsm3 ocean exit
use ccsm3_io ! ccsm3 ocean io
use ccsm3_forcing ! ccsm3 ocean/cpl6 comms
use ccsm3_time_management ! ccsm3 ocean time
use ccsm3_global_reductions ! ccsm3 ocean mpi comms
use shr_timer_mod ! ccsm3 shared timing routine
#endif
c
c --- -----------------------------------------
c --- MICOM-based HYbrid Coordinate Ocean Model
c --- H Y C O M
c --- v e r s i o n 2.2
c --- -----------------------------------------
c
implicit none
c
#if defined(USE_ESMF)
public HYCOM_SetServices
#else
public HYCOM_Init, HYCOM_Run, HYCOM_Final
#endif
c
logical, save, public :: put_export !set in main program
logical, save, public :: get_import !set in main program
logical, save, public :: end_of_run !set in HYCOM_Run
integer, save, public :: nts_day !set in HYCOM_init, timesteps/day
integer, save, public :: nts_ice !set in HYCOM_init, timesteps/ice
c
integer, save, private ::
& m,n
#if defined(USE_CCSM3)
logical, save, private ::
& end_month
integer, save, private ::
& k1m, !k1n in ccsm3_forcing
& mm,nn,
& termination, !if 1, stop now!
& ix0,ix1,ix2
character, save, private ::
& ccsm3_string*80
#endif
real*8, save, private ::
& d1,d2,d3,d4,d2a,d3a,d4a,
& ddsurf,ddiagf,dproff,dtilef,drstrf,dmeanf,
& dske,dskea,dsmr,dsmra,dsms,dsmsa,dsmt,dsmta,dsum,dsuma,
#if defined(STOKES)
& dskes,dskesa,
#endif
& dsumtr(mxtrcr),
& dtime,dtime0,dbimon,dmonth,dyear,dyear0,
& dsmall,dsmall2
real, save, private ::
& smr,sms,smt,smx,sum,smin,smax, tsur,
& coord,day1,day2,x,x1,time0,timav,cold,utotp,vtotp
real, save, private, allocatable ::
& sminy(:),smaxy(:)
integer, save, private ::
& nstep0,nod,
& jja,
& lt,ma0,ma1,ma2,ma3,mc0,mc1,mc2,mc3,
& mk0,mk1,mk2,mk3,mr0,mr1,mr2,mr3,mnth,iofl,
#if defined(USE_CCSM3)
& jday
* logical, save ::
* & linit
logical, save, private ::
& diagsv,hisurf,histry,hiprof,hitile,histmn,
& restrt,diag_tide
#else
& jday,ihour,iyear
logical, save, private ::
& linit,diagsv,hisurf,histry,hiprof,hitile,histmn,
& restrt,diag_tide
#endif
character, save, private ::
& intvl*3,c_ydh*14
c
real*8 hours1,days1,days6
private hours1,days1,days6
parameter (hours1=1.d0/24.d0,days1=1.d0,days6=6.d0)
c
c --- tfrz_n = nominal ice melting point (degC) for ice mask
real tfrz_n
private tfrz_n
parameter (tfrz_n=-1.79) !slightly above -1.8
c
#if defined(USE_ESMF)
c
c --- Data types for Import/Export array pointers
type ArrayPtrReal2D
real(ESMF_KIND_R4), dimension(:,:), pointer :: p
end type ArrayPtrReal2D
c
c --- Attribute names for fields
character(ESMF_MAXSTR), save ::
& attNameLongName = "long_name",
& attNameStdName = "standard_name",
& attNameUnits = "units",
& attNameSclFac = "scale_factor",
& attNameAddOff = "add_offset"
c
c --- Import Fields
integer, parameter :: numImpFields=11
character(ESMF_MAXSTR), save :: impFieldName( numImpFields),
& impFieldLongName(numImpFields),
& impFieldStdName( numImpFields),
& impFieldUnits( numImpFields)
real(ESMF_KIND_R4), save :: impFieldSclFac( numImpFields),
& impFieldAddOff( numImpFields)
integer, save :: impFieldHalo( numImpFields)
c
c --- Export Fields
integer, parameter :: numExpFields=7
character(ESMF_MAXSTR), save :: expFieldName( numExpFields),
& expFieldLongName(numExpFields),
& expFieldStdName( numExpFields),
& expFieldUnits( numExpFields)
real(ESMF_KIND_R4), save :: expFieldSclFac( numExpFields),
& expFieldAddOff( numExpFields)
integer, save :: expFieldHalo( numExpFields)
c
c --- ESMF related variables
type(ESMF_FieldBundle), save :: expBundle,
& impBundle
type(ESMF_Field), save :: expField(numExpFields),
& impField(numImpFields)
type(ArrayPtrReal2D), save :: expData( numExpFields),
& impData( numImpFields)
c
type(ESMF_Clock), save :: intClock
type(ESMF_VM), save :: vm
type(ESMF_DELayout), save :: deLayout
integer, save :: petCount, localPet,
& mpiCommunicator
type(ESMF_Grid), save :: grid2D
type(ESMF_DistGrid), save :: distgrid2D
type(ESMF_ArraySpec), save :: arraySpec2Dr
c
real, save, allocatable, dimension (:,:) ::
& sic_import !Sea Ice Concentration
&, sitx_import !Sea Ice X-Stress
&, sity_import !Sea Ice Y-Stress
&, siqs_import !Solar Heat Flux thru Ice to Ocean
&, sifh_import !Ice Freezing/Melting Heat Flux
&, sifs_import !Ice Freezing/Melting Salt Flux
&, sifw_import !Ice Net Water Flux
&, sit_import !Sea Ice Temperature
&, sih_import !Sea Ice Thickness
&, siu_import !Sea Ice X-Velocity
&, siv_import !Sea Ice Y-Velocity
&, ocn_mask !Ocean Currents Mask
logical, save ::
& ocn_mask_init
#endif
contains
#if defined(USE_ESMF)
subroutine HYCOM_SetServices(gridComp, rc)
c
type(ESMF_GridComp) :: gridComp
integer, intent(out) :: rc
c
call ESMF_GridCompSetEntryPoint(
& gridComp,
& ESMF_SETINIT,
& HYCOM_Init,
& ESMF_SINGLEPHASE,
& rc=rc)
call ESMF_GridCompSetEntryPoint(
& gridComp,
& ESMF_SETRUN,
& HYCOM_Run,
& ESMF_SINGLEPHASE,
& rc=rc)
call ESMF_GridCompSetEntryPoint(
& gridComp,
& ESMF_SETFINAL,
& HYCOM_Final,
& ESMF_SINGLEPHASE,
& rc=rc)
c
end subroutine HYCOM_SetServices
subroutine Setup_ESMF(gridComp, impState, expState, extClock, rc)
c
c --- Calling parameters
type(ESMF_GridComp) :: gridComp
type(ESMF_State) :: impState
type(ESMF_State) :: expState
type(ESMF_Clock) :: extClock
integer, intent(out) :: rc
c
c --- set up ESMF data structures for HYCOM.
c
real(ESMF_KIND_R4),pointer :: Xcoord(:,:),Ycoord(:,:)
integer, pointer :: mask_ptr(:,:)
integer :: i,j,rc2
integer :: lbnd(2),ubnd(2)
character(10) :: dimNames(2),dimUnits(2)
type(ESMF_Logical) :: periodic(2)
integer(ESMF_KIND_I4) :: year,month,day,hour,minute
integer(ESMF_KIND_I4) :: sec,msec,usec,nsec
real(8) :: dsec,dmsec,dusec,dnsec
type(ESMF_TimeInterval) :: timeStep, runDuration
type(ESMF_Time) :: startTime
character(ESMF_MAXSTR) :: msg, gridName
c
c --- Report
call ESMF_LogWrite("HYCOM Setup routine called",
& ESMF_LOG_INFO, rc=rc)
call ESMF_LogFlush(rc=rc)
c
c Attributes for import fields, identical to CICE export fields
impFieldAddOff(:) = 0.0 !default is no offset
impFieldSclFac(:) = 1.0 !default is no scale factor
impFieldHalo( :) = halo_ps !default is scalar p-grid
c
impFieldName( 1) = "sic"
impFieldLongName( 1) = "Sea Ice Concentration"
impFieldStdName( 1) = "sea_ice_area_fraction"
impFieldUnits( 1) = "1"
impFieldName( 2) = "sitx"
impFieldLongName( 2) = "Sea Ice X-Stress"
impFieldStdName( 2) = "downward_x_stress_at_sea_ice_base"
impFieldSclFac( 2) = -1.0 !field is upward
impFieldUnits( 2) = "Pa"
impFieldHalo( 2) = halo_pv !vector p-grid
impFieldName( 3) = "sity"
impFieldLongName( 3) = "Sea Ice Y-Stress"
impFieldStdName( 3) = "downward_y_stress_at_sea_ice_base"
impFieldSclFac( 3) = -1.0 !field is upward
impFieldUnits( 3) = "Pa"
impFieldHalo( 3) = halo_pv !vector p-grid
impFieldName( 4) = "siqs"
impFieldLongName( 4) = "Solar Heat Flux thru Ice to Ocean"
impFieldStdName( 4) = "downward_sea_ice_basal_solar_heat_flux"
impFieldUnits( 4) = "W m-2"
impFieldName( 5) = "sifh"
impFieldLongName( 5) = "Ice Freezing/Melting Heat Flux"
impFieldStdName( 5) = "upward_sea_ice_basal_heat_flux"
impFieldSclFac( 5) = -1.0 !field is downward
impFieldUnits( 5) = "W m-2"
impFieldName( 6) = "sifs"
impFieldLongName( 6) = "Ice Freezing/Melting Salt Flux"
impFieldStdName( 6) = "downward_sea_ice_basal_salt_flux"
impFieldUnits( 6) = "kg m-2 s-1"
impFieldName( 7) = "sifw"
impFieldLongName( 7) = "Ice Net Water Flux"
impFieldStdName( 7) = "downward_sea_ice_basal_water_flux"
impFieldUnits( 7) = "kg m-2 s-1"
impFieldName( 8) = "sit" !diagnostic
impFieldLongName( 8) = "Sea Ice Temperature"
impFieldStdName( 8) = "sea_ice_temperature"
impFieldAddOff( 8) = +273.15 !field is in degC
impFieldUnits( 8) = "K"
impFieldName( 9) = "sih" !diagnostic
impFieldLongName( 9) = "Sea Ice Thickness"
impFieldStdName( 9) = "sea_ice_thickness"
impFieldUnits( 9) = "m"
impFieldName( 10) = "siu" !diagnostic
impFieldLongName(10) = "Sea Ice X-Velocity"
impFieldStdName( 10) = "sea_ice_x_velocity"
impFieldUnits( 10) = "m s-1"
impFieldHalo( 10) = halo_pv !vector p-grid
impFieldName( 11) = "siv" !diagnostic
impFieldLongName(11) = "Sea Ice Y-Velocity"
impFieldStdName( 11) = "sea_ice_y_velocity"
impFieldUnits( 11) = "m s-1"
impFieldHalo( 11) = halo_pv !vector p-grid
*
* impFieldName( 12) = "patm"
* impFieldLongName(12) = "Surface Air Pressure"
* impFieldStdName( 12) = "surface_air_pressure"
* impFieldUnits( 12) = "Pa"
* impFieldName( 13) = "xwnd"
* impFieldLongName(13) = "X-Wind"
* impFieldStdName( 13) = "x_wind"
* impFieldUnits( 13) = "m s-1"
* impFieldHalo( 13) = halo_pv !vector p-grid
* impFieldName( 14) = "ywnd"
* impFieldLongName(14) = "Y-Wind"
* impFieldStdName( 14) = "y_wind"
* impFieldUnits( 14) = "m s-1"
* impFieldHalo( 14) = halo_pv !vector p-grid
c
c Attributes for export fields, identical to CICE import fields
expFieldAddOff(:) = 0.0 !default is no offset
expFieldSclFac(:) = 1.0 !default is no scale factor
expFieldHalo( :) = halo_ps !default is scalar p-grid
c
expFieldName( 1) = "sst"
expFieldLongName( 1) = "Sea Surface Temperature"
expFieldStdName( 1) = "sea_surface_temperature"
expFieldAddOff( 1) = +273.15 !field is in degC
expFieldUnits( 1) = "K"
expFieldName( 2) = "sss"
expFieldLongName( 2) = "Sea Surface Salinity"
expFieldStdName( 2) = "sea_surface_salinity"
expFieldUnits( 2) = "1e-3"
expFieldName( 3) = "ssu"
expFieldLongName( 3) = "Sea Surface X-Current"
expFieldStdName( 3) = "sea_water_x_velocity"
expFieldUnits( 3) = "m s-1"
expFieldHalo( 3) = halo_pv !vector p-grid
expFieldName( 4) = "ssv"
expFieldLongName( 4) = "Sea Surface Y-Current"
expFieldStdName( 4) = "sea_water_y_velocity"
expFieldUnits( 4) = "m s-1"
expFieldHalo( 4) = halo_pv !vector p-grid
expFieldName( 5) = "ssh"
expFieldLongName( 5) = "Sea Surface Height"
expFieldStdName( 5) = "sea_surface_height_above_sea_level"
expFieldUnits( 5) = "m"
expFieldName( 6) = "ssfi"
expFieldLongName( 6) = "Oceanic Heat Flux Available to Sea Ice"
expFieldStdName( 6) = "upward_sea_ice_basal_available_heat_flux"
expFieldSclFac( 6) = -1.0 !field is downward
expFieldUnits( 6) = "W m-2"
expFieldName( 7) = "mlt" !diagnostic
expFieldLongName( 7) = "Ocean Mixed Layer Thickness"
expFieldStdName( 7) = "ocean_mixed_layer_thickness"
expFieldUnits( 7) = "m"
c
c Create a DE layout to match HYCOM layout
deLayout = ESMF_DELayoutCreate(vm, rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "Setup_ESMF: DELayoutCreate failed", rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
c
c Create array specifications
call ESMF_ArraySpecSet(arraySpec2Dr,
& rank=2,
& typekind=ESMF_TYPEKIND_R4,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "Setup_ESMF: ArraySpecSet failed", rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
c
c Create an ESMF grid that matches the HYCOM 2D grid
dimNames(1)="longitude"; dimNames(2)="latitude";
dimUnits(1)="degrees_east"; dimUnits(2)="degrees_north";
periodic(1)=ESMF_TRUE
periodic(2)=ESMF_FALSE
c
c make a dist grid object using the deBlockList defined in mod_xc_mp.h
#if defined(ARCTIC)
c --- Arctic (tripole) domain, top row is replicated (ignore it)
distgrid2D=ESMF_DistGridCreate(minIndex=(/ 1, 1/),
& maxIndex=(/itdm,jtdm-1/),
& indexflag=ESMF_INDEX_GLOBAL,
& deBlockList=deBlockList(:,:,1:ijpr),
& rc=rc)
#else
distgrid2D=ESMF_DistGridCreate(minIndex=(/ 1, 1/),
& maxIndex=(/itdm,jtdm/),
& indexflag=ESMF_INDEX_GLOBAL,
& deBlockList=deBlockList(:,:,1:ijpr),
& rc=rc)
#endif
if (ESMF_LogMsgFoundError(rc,
& "Setup_ESMF: ESMF_DistGridCreate", rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
c
c Now create a 2D grid
grid2D=ESMF_GridCreate(distGrid=distGrid2D,
& coordTypeKind=ESMF_TYPEKIND_R4,
& coordDimCount=(/2,2/),
& indexflag=ESMF_INDEX_GLOBAL,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridCreate failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
c
c Add Grid Coordinates
call ESMF_GridAddCoord(grid=grid2D,
& staggerloc=ESMF_STAGGERLOC_CENTER,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridAddCoord failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
call ESMF_GridGetCoord(grid=grid2D,
& CoordDim=1,
& localDe=0,
& staggerloc=ESMF_STAGGERLOC_CENTER,
& computationalLbound=lbnd,
& computationalUbound=ubnd,
& fptr=Xcoord,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridGetCoord-1 failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
#if defined(ARCTIC)
c --- Arctic (tripole) domain, top row is replicated (ignore it)
jja = min( jj, jtdm-1-j0 )
#else
jja = jj
#endif
do j= 1,jja
do i= 1,ii
Xcoord(i+i0,j+j0) = plon(i,j)
enddo
enddo
call ESMF_GridGetCoord(grid=grid2D,
& CoordDim=2,
& localDe=0,
& staggerloc=ESMF_STAGGERLOC_CENTER,
& computationalLbound=lbnd,
& computationalUbound=ubnd,
& fptr=Ycoord,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridGetCoord-2 failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
do j= 1,jja
do i= 1,ii
Ycoord(i+i0,j+j0) = plat(i,j)
enddo
enddo
CALL ESMF_GridAddItem(grid=grid2D,
& staggerloc=ESMF_STAGGERLOC_CENTER,
& item=ESMF_GRIDITEM_MASK,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridAddItem failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
CALL ESMF_GridGetItem(grid=grid2D,
& localDE=0,
& staggerloc=ESMF_STAGGERLOC_CENTER,
& item=ESMF_GRIDITEM_MASK,
& fptr=mask_ptr,
& rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "GridGetItem failed",rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
mask_ptr(:,:) = 0 !all land, outside active tile
do j= 1,jja
do i= 1,ii
mask_ptr(i+i0,j+j0) = ishlf(i,j)
enddo
enddo
c
c Associate grid with ESMF gridded component
call ESMF_GridCompSet(gridComp, grid=grid2D, rc=rc)
if (ESMF_LogMsgFoundError(rc,
& "Setup_ESMF: GridCompSet", rcToReturn=rc2))
& call ESMF_Finalize(rc=rc)
c
c Setup export fields, bundles & state
do i=1,numExpFields
expField(i)=ESMF_FieldCreate(grid=grid2D,
& arrayspec=arraySpec2Dr,
& indexflag=ESMF_INDEX_GLOBAL,
& staggerLoc=ESMF_STAGGERLOC_CENTER,
& name=trim(expFieldName(i)),
& rc=rc)
call ESMF_FieldGet(expField(i),0,expData(i)%p,rc=rc)
expData(i)%p(:,:) = 0.0
enddo
c
c Create bundle from list of fields
expBundle=ESMF_FieldBundleCreate(numExpFields,
& expField(:), name='HYCOM Export',
& rc=rc)
c
c Add bundle to the export state
call ESMF_StateAdd(expState,expBundle,rc=rc)
c
c Setup import fields, bundles & state
do i = 1,numImpFields
impField(i)=ESMF_FieldCreate(grid2D,arraySpec2Dr,
& StaggerLoc=ESMF_STAGGERLOC_CENTER,
& name=trim(impFieldName(i)),
& rc=rc)
call ESMF_FieldGet(impField(i),0,impData(i)%p,rc=rc)
impData(i)%p(:,:)=0.0 ! Initialize fields
enddo
c
allocate( sic_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sitx_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sity_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& siqs_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sifh_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sifs_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sifw_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sit_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& sih_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& siu_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
& siv_import(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
call mem_stat_add( 11*(idm+2*nbdy)*(jdm+2*nbdy) )
c
sic_import(:,:) = 0.0 !Sea Ice Concentration
sitx_import(:,:) = 0.0 !Sea Ice X-Stress
sity_import(:,:) = 0.0 !Sea Ice Y-Stress
siqs_import(:,:) = 0.0 !Solar Heat Flux thru Ice to Ocean
sifh_import(:,:) = 0.0 !Ice Freezing/Melting Heat Flux
sifs_import(:,:) = 0.0 !Ice Freezing/Melting Salt Flux
sifw_import(:,:) = 0.0 !Ice Net Water Flux
sit_import(:,:) = 0.0 !Sea Ice Temperature
sih_import(:,:) = 0.0 !Sea Ice Thickness
siu_import(:,:) = 0.0 !Sea Ice X-Velocity
siv_import(:,:) = 0.0 !Sea Ice Y-Velocity
c
c Create bundle from list of fields
impBundle=ESMF_FieldBundleCreate(numImpFields,
& impField(:),
& name='HYCOM Import',
& rc=rc)
c
c Add bundle to the import state
call ESMF_StateAdd(impState,impBundle,rc=rc)
c
ocn_mask_init = .true. !still need to initialize ocn_mask
c
end subroutine Setup_ESMF
subroutine Export_ESMF()
c
c --- Fill export state.
c --- Calculate ssfi "in place"
c
integer i,j,k,rc
real ssh2m
real tmxl,smxl,umxl,vmxl,hfrz,tfrz,t2f,ssfi
real dp1,usur1,vsur1,psur1,dp2,usur2,vsur2,psur2,thksur
c
c --- Report
call ESMF_LogWrite("HYCOM Export routine called",
& ESMF_LOG_INFO, rc=rc)
call ESMF_LogFlush(rc=rc)
c
if (ocn_mask_init) then !very 1st call to this routine
ocn_mask_init = .false.
c
allocate( ocn_mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
call mem_stat_add( (idm+2*nbdy)*(jdm+2*nbdy) )
c
if (iceflg.eq.4) then
ocn_mask(:,:) = 0.0 !export ocean currents nowhere
elseif (nestfq.ne.0.0) then
c export ocean currents away from open boundaries
do j= 1,jj
do i= 1,ii
if (rmunv(i,j).ne.0.0) then
ocn_mask(i,j) = 0.0
else
ocn_mask(i,j) = 1.0
endif
enddo !i
enddo !j
do i= 1,10
call psmooth(ocn_mask,0,0, ip, util1) !not efficient, but only done once
enddo !i
else
ocn_mask(:,:) = 1.0 !export ocean currents everywhere
endif
endif !ocn_mask_init
c
c --- Assume Export State is as defined in Setup_ESMF
c --- Average two time levels since (the coupling frequency) icpfrq >> 2
c
call xctilr(u( 1-nbdy,1-nbdy,1,1),1,2*kk, 1,1, halo_uv)
call xctilr(v( 1-nbdy,1-nbdy,1,1),1,2*kk, 1,1, halo_vv)
call xctilr(ubavg( 1-nbdy,1-nbdy, 1),1, 2, 1,1, halo_uv)
call xctilr(vbavg( 1-nbdy,1-nbdy, 1),1, 2, 1,1, halo_vv)
c
ssh2m = 1.0/g
do j= 1,jja
do i= 1,ii
if (ishlf(i,j).eq.1) then
c --- quantities for available freeze/melt heat flux
c --- relax to tfrz with e-folding time of icefrq time steps
c --- assuming the effective surface layer thickness is hfrz
c --- multiply by dpbl(i,j)/hfrz to get the actual e-folding time
hfrz = min( thkfrz*onem, dpbl(i,j) )
t2f = (spcifh*hfrz)/(baclin*icefrq*g)
c --- average both available time steps, to avoid time splitting.
smxl = 0.5*(saln(i,j,1,n)+saln(i,j,1,m))
tmxl = 0.5*(temp(i,j,1,n)+temp(i,j,1,m))
tfrz = tfrz_0 + smxl*tfrz_s !salinity dependent freezing point
ssfi = (tfrz-tmxl)*t2f !W/m^2 into ocean
c --- average currents over top thkcdw meters
thksur = onem*min( thkcdw, depths(i,j) )
usur1 = 0.0
vsur1 = 0.0
psur1 = 0.0
usur2 = 0.0
vsur2 = 0.0
psur2 = 0.0
do k= 1,kk
dp1 = min( dp(i,j,k,1), max( 0.0, thksur-psur1 ) )
#if defined(STOKES)
usur1=usur1+dp1*(u(i,j,k,1)+u(i+1,j,k,1)+usd(i,j,k)+usd(i+1,j,k))
vsur1=vsur1+dp1*(v(i,j,k,1)+v(i,j+1,k,1)+vsd(i,j,k)+vsd(i,j+1,k))
#else
usur1 = usur1 + dp1*(u(i,j,k,1)+u(i+1,j,k,1))
vsur1 = vsur1 + dp1*(v(i,j,k,1)+v(i,j+1,k,1))
#endif
psur1 = psur1 + dp1
dp2 = min( dp(i,j,k,2), max( 0.0, thksur-psur2 ) )
#if defined(STOKES)
usur2=usur2+dp2*(u(i,j,k,1)+u(i+1,j,k,2)+usd(i,j,k)+usd(i+1,j,k))
vsur2=vsur2+dp2*(v(i,j,k,1)+v(i,j+1,k,2)+vsd(i,j,k)+vsd(i,j+1,k))
#else
usur2 = usur2 + dp2*(u(i,j,k,2)+u(i+1,j,k,2))
vsur2 = vsur2 + dp2*(v(i,j,k,2)+v(i,j+1,k,2))
#endif
psur2 = psur2 + dp2
if (min(psur1,psur2).ge.thksur) then
exit
endif
enddo
#if defined(STOKES)
umxl = 0.25*( usur1/psur1+ubavg(i,j,1) + usdbavg(i,j) +
& ubavg(i+1,j,1) + usdbavg(i+1,j) +
& usur2/psur2 + ubavg(i, j,2) + usdbavg(i,j) +
& ubavg(i+1,j,2) + usdbavg(i+1,j) )
vmxl = 0.25*( vsur1/psur1+vbavg(i,j,1) + vsdbavg(i,j) +
& vbavg(i,j+1,1) + vsdbavg(i,j+1) +
& vsur2/psur2 + vbavg(i,j, 2) + vsdbavg(i,j) +
& vbavg(i,j+1,2) + vadbavg(i,j+1) )
#else
umxl = 0.25*( usur1/psur1 + ubavg(i, j,1) +
& ubavg(i+1,j,1) +
& usur2/psur2 + ubavg(i, j,2) +
& ubavg(i+1,j,2) )
vmxl = 0.25*( vsur1/psur1 + vbavg(i,j, 1) +
& vbavg(i,j+1,1) +
& vsur2/psur2 + vbavg(i,j, 2) +
& vbavg(i,j+1,2) )
#endif
util2(i,j) = umxl
util3(i,j) = vmxl
expData(1)%p(i+i0,j+j0) = tmxl
expData(2)%p(i+i0,j+j0) = smxl
expData(5)%p(i+i0,j+j0) = ssh2m*srfhgt(i,j) !ssh in m
expData(6)%p(i+i0,j+j0) = max(-1000.0,min(1000.0,ssfi)) !as in CICE
expData(7)%p(i+i0,j+j0) = dpbl(i,j)*qonem
else
util2(i,j) = 0.0
util3(i,j) = 0.0
endif !ishlf:else
enddo !i
enddo !j
c
c --- Smooth surface ocean velocity fields
#if defined(ARCTIC)
call xctila( util2,1,1,halo_pv)
call xctila( util3,1,1,halo_pv)
#endif
call psmooth(util2,0,0, ishlf, util1)
call psmooth(util3,0,0, ishlf, util1)
do j= 1,jja
do i= 1,ii
if (ishlf(i,j).eq.1) then
expData(3)%p(i+i0,j+j0) = util2(i,j)*ocn_mask(i,j)
expData(4)%p(i+i0,j+j0) = util3(i,j)*ocn_mask(i,j)
endif !ishlf
enddo !i
enddo !j
c
c --- Report
call ESMF_LogWrite("HYCOM Export routine returned",
& ESMF_LOG_INFO, rc=rc)
call ESMF_LogFlush(rc=rc)
c
end subroutine Export_ESMF
subroutine Import_ESMF()
c
c --- Extract import state.
c
integer i,j,rc
c
c --- Report
call ESMF_LogWrite("HYCOM Import routine called",
& ESMF_LOG_INFO, rc=rc)
call ESMF_LogFlush(rc=rc)
c
c --- Assume Import State is as defined in Setup_ESMF
c
#if defined(ARCTIC)
c --- Arctic (tripole) domain, top row is replicated (ignore it)
jja = min( jj, jtdm-1-j0 )
#else
jja = jj
#endif
do j= 1,jja
do i= 1,ii
if (ishlf(i,j).eq.1) then
sic_import(i,j) = impData( 1)%p(i+i0,j+j0) !Sea Ice Concentration
sitx_import(i,j) = impData( 2)%p(i+i0,j+j0) !Sea Ice X-Stress
sity_import(i,j) = impData( 3)%p(i+i0,j+j0) !Sea Ice Y-Stress
siqs_import(i,j) = impData( 4)%p(i+i0,j+j0) !Solar Heat Flux thru Ice to Ocean
sifh_import(i,j) = impData( 5)%p(i+i0,j+j0) !Ice Freezing/Melting Heat Flux
sifs_import(i,j) = impData( 6)%p(i+i0,j+j0) !Ice Freezing/Melting Salt Flux
sifw_import(i,j) = impData( 7)%p(i+i0,j+j0) !Ice Net Water Flux
sit_import(i,j) = impData( 8)%p(i+i0,j+j0) !Sea Ice Temperature
sih_import(i,j) = impData( 9)%p(i+i0,j+j0) !Sea Ice Thickness
siu_import(i,j) = impData(10)%p(i+i0,j+j0) !Sea Ice X-Velocity
siv_import(i,j) = impData(11)%p(i+i0,j+j0) !Sea Ice Y-Velocity
if (iceflg.ge.2 .and. icmflg.ne.3) then
covice(i,j) = impData(1)%p(i+i0,j+j0) !Sea Ice Concentration
si_c(i,j) = impData(1)%p(i+i0,j+j0) !Sea Ice Concentration
if (covice(i,j).gt.0.0) then
si_tx(i,j) = -impData( 2)%p(i+i0,j+j0) !Sea Ice X-Stress into ocean
si_ty(i,j) = -impData( 3)%p(i+i0,j+j0) !Sea Ice Y-Stress into ocean
fswice(i,j) = impData( 4)%p(i+i0,j+j0) !Solar Heat Flux thru Ice to Ocean
flxice(i,j) = fswice(i,j) +
& impData( 5)%p(i+i0,j+j0) !Ice Freezing/Melting Heat Flux
sflice(i,j) = impData( 6)%p(i+i0,j+j0)*1.e3 -
& impData( 7)%p(i+i0,j+j0)*saln(i,j,1,n)
!Ice Virtual Salt Flux
temice(i,j) = impData( 8)%p(i+i0,j+j0) !Sea Ice Temperature
si_t(i,j) = impData( 8)%p(i+i0,j+j0) !Sea Ice Temperature
thkice(i,j) = impData( 9)%p(i+i0,j+j0) !Sea Ice Thickness
si_h(i,j) = impData( 9)%p(i+i0,j+j0) !Sea Ice Thickness
si_u(i,j) = impData(10)%p(i+i0,j+j0) !Sea Ice X-Velocity
si_v(i,j) = impData(11)%p(i+i0,j+j0) !Sea Ice Y-Velocity
else
si_tx(i,j) = 0.0
si_ty(i,j) = 0.0
fswice(i,j) = 0.0
flxice(i,j) = 0.0
sflice(i,j) = 0.0
temice(i,j) = 0.0
si_t(i,j) = 0.0
thkice(i,j) = 0.0
si_h(i,j) = 0.0
si_u(i,j) = 0.0
si_v(i,j) = 0.0
endif !covice
elseif (iceflg.ge.2 .and. icmflg.eq.3) then
si_c(i,j) = impData( 1)%p(i+i0,j+j0) !Sea Ice Concentration
if (si_c(i,j).gt.0.0) then
si_tx(i,j) = -impData( 2)%p(i+i0,j+j0) !Sea Ice X-Stress into ocean
si_ty(i,j) = -impData( 3)%p(i+i0,j+j0) !Sea Ice Y-Stress into ocean
si_h(i,j) = impData( 9)%p(i+i0,j+j0) !Sea Ice Thickness
si_t(i,j) = impData( 8)%p(i+i0,j+j0) !Sea Ice Temperature
si_u(i,j) = impData(10)%p(i+i0,j+j0) !Sea Ice X-Velocity
si_v(i,j) = impData(11)%p(i+i0,j+j0) !Sea Ice Y-Velocity
else
si_tx(i,j) = 0.0
si_ty(i,j) = 0.0
si_h(i,j) = 0.0
si_t(i,j) = 0.0
si_u(i,j) = 0.0
si_v(i,j) = 0.0
endif !covice
endif !iceflg>=2 (icmflg)
endif !ishlf
enddo !i
enddo !j
#if defined(ARCTIC)
c
c --- update last active row of array
call xctila( sic_import,1,1,halo_ps) !Sea Ice Concentration
call xctila(sitx_import,1,1,halo_pv) !Sea Ice X-Stress
call xctila(sity_import,1,1,halo_pv) !Sea Ice Y-Stress
call xctila(siqs_import,1,1,halo_ps) !Solar Heat Flux thru Ice to Ocean
call xctila(sifh_import,1,1,halo_ps) !Ice Freezing/Melting Heat Flux
call xctila(sifs_import,1,1,halo_ps) !Ice Freezing/Melting Salt Flux
call xctila(sifw_import,1,1,halo_ps) !Ice Net Water Flux
call xctila( sit_import,1,1,halo_ps) !Sea Ice Temperature
call xctila( sih_import,1,1,halo_ps) !Sea Ice Thickness
call xctila( siu_import,1,1,halo_pv) !Sea Ice X-Velocity
call xctila( siv_import,1,1,halo_pv) !Sea Ice Y-Velocity
if (iceflg.ge.2 .and. icmflg.ne.3) then
call xctila(covice,1,1,halo_ps) !Sea Ice Concentration
call xctila( si_c,1,1,halo_ps) !Sea Ice Concentration
call xctila( si_tx,1,1,halo_pv) !Sea Ice X-Stress into ocean
call xctila( si_ty,1,1,halo_pv) !Sea Ice Y-Stress into ocean
call xctila(fswice,1,1,halo_ps) !Solar Heat Flux thru Ice to Ocean
call xctila(flxice,1,1,halo_ps) !Ice Freezing/Melting Heat Flux
call xctila(sflice,1,1,halo_ps) !Ice Virtual Salt Flux
call xctila(temice,1,1,halo_ps) !Sea Ice Temperature
call xctila( si_t,1,1,halo_ps) !Sea Ice Temperature
call xctila(thkice,1,1,halo_ps) !Sea Ice Thickness
call xctila( si_h,1,1,halo_ps) !Sea Ice Thickness
call xctila( si_u,1,1,halo_pv) !Sea Ice X-Velocity
call xctila( si_v,1,1,halo_pv) !Sea Ice Y-Velocity
elseif (iceflg.ge.2 .and. icmflg.eq.3) then
call xctila( si_c,1,1,halo_ps) !Sea Ice Concentration
call xctila( si_tx,1,1,halo_pv) !Sea Ice X-Stress into ocean
call xctila( si_ty,1,1,halo_pv) !Sea Ice Y-Stress into ocean
call xctila( si_h,1,1,halo_ps) !Sea Ice Thickness
call xctila( si_t,1,1,halo_ps) !Sea Ice Temperature
call xctila( si_u,1,1,halo_pv) !Sea Ice X-Velocity
call xctila( si_v,1,1,halo_pv) !Sea Ice Y-Velocity
endif
#endif
c
c --- Smooth Sea Ice velocity fields
call psmooth(si_u,0,0, ishlf, util1)
call psmooth(si_v,0,0, ishlf, util1)
#if defined(ARCTIC)
call xctila(si_u,1,1,halo_pv)
call xctila(si_v,1,1,halo_pv)
#endif
c --- copy back from si_ to impData for Archive_ESMF
do j= 1,jja
do i= 1,ii
if (si_c(i,j).gt.0.0) then
impData(10)%p(i+i0,j+j0) = si_u(i,j) !Sea Ice X-Velocity
impData(11)%p(i+i0,j+j0) = si_v(i,j) !Sea Ice X-Velocity
endif !si_c
enddo !i
enddo !j
c
c --- Report
call ESMF_LogWrite("HYCOM Import routine returned",
& ESMF_LOG_INFO, rc=rc)
call ESMF_LogFlush(rc=rc)
c
end subroutine Import_ESMF
subroutine Archive_ESMF(iyear,jday,ihour)
integer iyear,jday,ihour
c
c --- Create a HYCOM "archive-like" file from Import/Export state.
c --- Import state may not be at the same time as Export.
c --- Ice Drift has been smoothed since import.
c
logical hycom_isnaninf !function to detect NaN and Inf
c
character*8 cname
character*80 cfile
logical lexist
integer i,j,k,nop,nopa
real coord,xmin,xmax,sumssu,sumssv,sumsiu,sumsiv
c
write(cfile,'(a,i4.4,a1,i3.3,a1,i2.2)')
& 'arche.',iyear,'_',jday,'_',ihour
nopa=13
nop =13+uoff
c
c --- Only write out one archive per hour
c
inquire(file=trim(cfile)//'.a',exist=lexist)
if (lexist) then
if (mnproc.eq.1) then
write(lp,*) 'skip: ',trim(cfile)
call flush(lp)
endif !1st tile
return
else
if (mnproc.eq.1) then
write(lp,*) 'open: ',trim(cfile)
call flush(lp)
endif !1st tile
endif
call xcsync(flush_lp)
c
call zaiopf(trim(cfile)//'.a', 'new', nopa)
if (mnproc.eq.1) then
open (unit=nop,file=trim(cfile)//'.b',status='new') !uoff+13
write(nop,116) ctitle,iversn,iexpt,yrflag,itdm,jtdm
call flush(nop)
endif !1st tile
116 format (a80/a80/a80/a80/
& i5,4x,'''iversn'' = hycom version number x10'/
& i5,4x,'''iexpt '' = experiment number x10'/
& i5,4x,'''yrflag'' = days in year flag'/
& i5,4x,'''idm '' = longitudinal array size'/
& i5,4x,'''jdm '' = latitudinal array size'/
& 'field time step model day',
& ' k dens min max')
c
c --- surface fields
c
coord=0.0
do k= 1,numExpFields
do j= 1,jja
do i= 1,ii
if (ishlf(i,j).eq.1) then
util1(i,j) = expData(k)%p(i+i0,j+j0)
endif !ishlf
enddo !i
enddo !j
#if defined(ARCTIC)
call xctila(util1,1,1,expFieldHalo(k))
#endif
cname = expFieldName(k)(1:8)
call zaiowr(util1,ishlf,.true.,
& xmin,xmax, nopa, .false.)
if (mnproc.eq.1) then
write (nop,117) cname,nstep,time,0,coord,xmin,xmax
call flush(nop)
endif !1st tile
enddo !k
do j= 1,jja
do i= 1,ii
if (ishlf(i,j).eq.1) then
util2(i,j) = impData(1)%p(i+i0,j+j0) !ice concentration
else
util2(i,j) = 0.0
endif !ishlf
enddo !i
enddo !j
#if defined(ARCTIC)
call xctila(util2,1,1,halo_ps)
#endif
cname = impFieldName(1)(1:8)
call zaiowr(util2,ishlf,.true.,
& xmin,xmax, nopa, .false.)
if (mnproc.eq.1) then
write (nop,117) cname,nstep,time,0,coord,xmin,xmax
call flush(nop)
endif !1st tile
do k= 2,3 !si_tx,si_ty
do j= 1,jja
do i= 1,ii
if (util2(i,j).ne.0.0) then
util1(i,j) = -impData(k)%p(i+i0,j+j0) !into ocean
else
util1(i,j) = 0.0
endif !ice:no-ice
enddo !i
enddo !j
#if defined(ARCTIC)
call xctila(util1,1,1,impFieldHalo(k))
#endif
cname = impFieldName(k)(1:8)
call zaiowr(util1,ishlf,.true.,
& xmin,xmax, nopa, .false.)
if (mnproc.eq.1) then
write (nop,117) cname(1:4)//'down',
& nstep,time,0,coord,xmin,xmax
call flush(nop)
endif !1st tile
enddo !k
do k= 4,7 !fluxes
do j= 1,jja
do i= 1,ii
if (util2(i,j).ne.0.0) then
util1(i,j) = util2(i,j)*impData(k)%p(i+i0,j+j0)
else
util1(i,j) = hugel !mask where there is no ice
endif !ice:no-ice
enddo !i
enddo !j
#if defined(ARCTIC)
vland = hugel
call xctila(util1,1,1,impFieldHalo(k))
vland = 0.0
#endif
cname = impFieldName(k)(1:8)
call zaiowr(util1,ishlf,.false., !mask on ice
& xmin,xmax, nopa, .false.)
if (mnproc.eq.1) then
write (nop,117) cname,nstep,time,0,coord,xmin,xmax
call flush(nop)
endif !1st tile
enddo !k
do k= 8,numImpFields
do j= 1,jja
do i= 1,ii
if (util2(i,j).ne.0.0) then
util1(i,j) = impData(k)%p(i+i0,j+j0)
else
util1(i,j) = hugel !mask where there is no ice
endif !ice:no-ice
enddo !i
enddo !j
#if defined(ARCTIC)
vland = hugel
call xctila(util1,1,1,impFieldHalo(k))