-
Notifications
You must be signed in to change notification settings - Fork 13
/
cost_final.F
213 lines (177 loc) · 5.43 KB
/
cost_final.F
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
#include "COST_OPTIONS.h"
#ifdef ALLOW_CTRL
# include "CTRL_OPTIONS.h"
#endif
SUBROUTINE COST_FINAL( myThid )
c ==================================================================
c SUBROUTINE cost_final
c ==================================================================
c
c o Sum of all cost function contributions.
c
c ==================================================================
c SUBROUTINE cost_final
c ==================================================================
IMPLICIT NONE
c == global variables ==
#include "EEPARAMS.h"
#include "SIZE.h"
#include "PARAMS.h"
#include "cost.h"
#ifdef ALLOW_CTRL
# include "CTRL_SIZE.h"
# include "CTRL.h"
#endif
#ifdef ALLOW_DIC
# include "DIC_COST.h"
#endif
#ifdef ALLOW_COST_SHELFICE
# include "SHELFICE_COST.h"
#endif
#ifdef ALLOW_PROFILES
# include "PROFILES_SIZE.h"
# include "profiles.h"
#endif
c == routine arguments ==
INTEGER myThid
#ifdef ALLOW_COST
c == local variables ==
INTEGER bi,bj
_RL glob_fc, loc_fc
#ifdef ALLOW_PROFILES
INTEGER num_file,num_var
#endif
CHARACTER*(MAX_LEN_MBUF) msgBuf
c == end of interface ==
#ifdef ALLOW_SEAICE
IF (useSEAICE) CALL SEAICE_COST_FINAL( myThid )
#endif
#ifdef ALLOW_SHELFICE
IF (useShelfice) CALL SHELFICE_COST_FINAL (myThid)
#endif
#if (defined(ALLOW_STREAMICE) && defined(ALLOW_COST_STREAMICE))
IF (useStreamice) CALL STREAMICE_COST_FINAL (myThid)
#endif
#ifdef ALLOW_THSICE
IF (useThSIce) CALL THSICE_COST_FINAL (myThid)
#endif
#ifdef ALLOW_ECCO
IF (useECCO) CALL ECCO_COST_FINAL (myThid)
#endif
#ifdef ALLOW_COST_STATE_FINAL
CALL COST_STATE_FINAL (myThid)
cgf : effectively using this in adjoint requires the
c use of adjoint_state_final. That will activate the
c objf_state_final vector in place of the fc scalar.
c objf_state_final is therefore not added to fc.
#endif
#ifdef ALLOW_COST_VECTOR
cgf : same idea as for ALLOW_COST_STATE_FINAL
CALL COST_VECTOR (myThid)
#endif
# ifdef ALLOW_COST_TEST
CALL COST_TEST (myThid)
# endif
# ifdef ALLOW_COST_ATLANTIC_HEAT
CALL COST_ATLANTIC_HEAT (myThid)
# endif
#ifdef ALLOW_COST_HFLUXM
CALL COST_HFLUX (myThid)
cgf : to compile previous line user is expected to provide cost_hflux.F
#endif
#ifdef ALLOW_COST_TEMP
CALL COST_TEMP (myThid)
cgf : to compile previous line user is expected to provide cost_temp.F
#endif
#ifdef ALLOW_COST_DEPTH
CALL COST_DEPTH( myThid )
#endif
WRITE(msgBuf,'(A,D22.15)') ' early fc = ', fc
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
c-- Sum up all contributions.
loc_fc = 0.
DO bj = myByLo(myThid), myByHi(myThid)
DO bi = myBxLo(myThid), myBxHi(myThid)
#ifdef ALLOW_COST_TEST
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_test(bi,bj) = ', objf_test(bi,bj)
#endif
#ifdef ALLOW_COST_TRACER
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_tracer(bi,bj) = ', objf_tracer(bi,bj)
#endif
#ifdef ALLOW_COST_ATLANTIC_HEAT
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_atl(bi,bj) = ', objf_atl(bi,bj)
#endif
#ifdef ALLOW_COST_TEMP
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_temp_tut(bi,bj) = ', objf_temp_tut(bi,bj)
#endif
#ifdef ALLOW_COST_HFLUXM
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_hflux_tut(bi,bj) = ', objf_hflux_tut(bi,bj)
#endif
#ifdef ALLOW_COST_DEPTH
WRITE(standardMessageUnit,'(A,D22.15)')
& ' --> objf_depth(bi,bj) = ', objf_depth(bi,bj)
#endif
tile_fc(bi,bj) = tile_fc(bi,bj)
#ifdef ALLOW_COST_TEST
& + mult_test * objf_test(bi,bj)
#endif
#ifdef ALLOW_COST_TRACER
& + mult_tracer * objf_tracer(bi,bj)
#endif
#ifdef ALLOW_COST_ATLANTIC_HEAT
& + mult_atl * objf_atl(bi,bj)
#endif
#ifdef ALLOW_COST_TEMP
& + mult_temp_tut * objf_temp_tut(bi,bj)
#endif
#ifdef ALLOW_COST_HFLUXM
& + mult_hflux_tut * objf_hflux_tut(bi,bj)
#endif
#ifdef ALLOW_COST_DEPTH
& + mult_depth * objf_depth(bi,bj)
#endif
#ifdef ALLOW_PROFILES
IF (.NOT.useECCO) THEN
DO num_file=1,NFILESPROFMAX
DO num_var=1,NVARMAX
tile_fc(bi,bj) = tile_fc(bi,bj)
& + mult_profiles(num_file,num_var)
& *objf_profiles(num_file,num_var,bi,bj)
ENDDO
ENDDO
ENDIF
#endif
loc_fc = loc_fc + tile_fc(bi,bj)
ENDDO
ENDDO
WRITE(msgBuf,'(A,D22.15)') ' local fc = ', loc_fc
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
c-- Do global summation.
CALL GLOBAL_SUM_TILE_RL( tile_fc, glob_fc, myThid )
_BEGIN_MASTER( myThid )
fc = fc + glob_fc
_END_MASTER( myThid )
c-- Add contributions from global mean constraints
_BEGIN_MASTER( myThid )
fc = fc + glofc
_END_MASTER( myThid )
#ifdef ALLOW_DIC_COST
cph-- quickly for testing
fc = totcost
#endif
WRITE(msgBuf,'(A,D22.15)') ' global fc = ', fc
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
c-- to avoid re-write of output in reverse checkpointing loops,
c-- switch off output flag :
CALL TURNOFF_MODEL_IO( 0, myThid )
#endif /* ALLOW_COST */
RETURN
END