Merge lp:~fluidity-core/fluidity/adjoint into lp:fluidity
- adjoint
- Merge into dev-trunk
Status: | Merged |
---|---|
Merged at revision: | 3521 |
Proposed branch: | lp:~fluidity-core/fluidity/adjoint |
Merge into: | lp:fluidity |
Diff against target: |
152406 lines (+52346/-96549) 431 files modified
Makefile.in (+2/-2) aclocal.m4 (+5/-5) adjoint/Adjoint_Controls.F90 (+611/-0) adjoint/Adjoint_Functional_Evaluation.F90 (+108/-28) adjoint/Adjoint_Global_Variables.F90 (+0/-1) adjoint/Adjoint_Main_Loop.F90 (+58/-40) adjoint/Adjoint_Python_Fortran.F90 (+6/-3) adjoint/Burgers_Adjoint_Callbacks.F90 (+340/-20) adjoint/Burgers_Control_Callbacks.F90 (+183/-0) adjoint/Forward_Main_Loop.F90 (+99/-4) adjoint/Libadjoint_Data_Callbacks.F90 (+23/-0) adjoint/Makefile.dependencies (+38/-5) adjoint/Makefile.in (+22/-4) adjoint/Mangle_Dirichlet_Rows_Module.F90 (+23/-1) adjoint/Mangle_Options_Tree.F90 (+19/-10) adjoint/Shallow_Water_Adjoint_Callbacks.F90 (+1/-0) adjoint/Shallow_Water_Control_Callbacks.F90 (+203/-0) adjoint/adBuffer.c (+476/-0) adjoint/adBufferFortran.f (+1848/-0) adjoint/adStack.c (+683/-0) adjoint/adStack.h (+75/-0) adjoint/adjoint_python.c (+14/-2) adjoint/simple_advection.f90 (+83/-0) adjoint/simple_advection_b.f90 (+209/-0) adjoint/simple_advection_d.f90 (+199/-0) adjoint/tests/test_adj_variables_from_python.F90 (+5/-1) assemble/Burgers_Assembly.F90 (+84/-0) assemble/Makefile.dependencies (+16/-9) assemble/Makefile.in (+1/-1) assemble/Manifold_Projections.F90 (+3/-1) configure (+30/-13) configure.in (+24/-8) femtools/Makefile.dependencies (+20/-19) main/Burgers_Equation.F90 (+104/-61) main/Makefile.dependencies (+26/-23) main/Shallow_Water.F90 (+26/-7) main/Simple_Shallow_Water.F90 (+7/-5) python/fluidity_tools.py (+88/-1) schemas/adjoint_options.rnc (+54/-1) schemas/adjoint_options.rng (+79/-0) schemas/optimality.rnc (+189/-0) schemas/optimality.rng (+222/-0) scripts/optimality.py (+720/-0) tests/burgers_adjoint_bc/Makefile (+0/-5) tests/burgers_adjoint_bc/adjoint_bc.bml (+0/-213) tests/burgers_adjoint_bc/burgers_adjoint_bc.xml (+0/-31) tests/burgers_adjoint_bc/notes_from_colin.tex (+0/-154) tests/burgers_adjoint_bc/play.py (+0/-67) tests/burgers_mms_adjoint/Makefile (+0/-10) tests/burgers_mms_adjoint/burgers.sage (+0/-15) tests/burgers_mms_adjoint/burgers_mms_adjoint.xml (+0/-69) tests/burgers_mms_adjoint/mms_A.bml (+0/-231) tests/burgers_mms_adjoint/mms_A.bound (+0/-4) tests/burgers_mms_adjoint/mms_A.ele (+0/-102) tests/burgers_mms_adjoint/mms_A.node (+0/-103) tests/burgers_mms_adjoint/mms_B.bml (+0/-231) tests/burgers_mms_adjoint/mms_B.bound (+0/-4) tests/burgers_mms_adjoint/mms_B.ele (+0/-202) tests/burgers_mms_adjoint/mms_B.node (+0/-203) tests/burgers_mms_adjoint/mms_C.bml (+0/-231) tests/burgers_mms_adjoint/mms_C.bound (+0/-4) tests/burgers_mms_adjoint/mms_C.ele (+0/-402) tests/burgers_mms_adjoint/mms_C.node (+0/-403) tests/burgers_mms_adjoint/mms_D.bml (+0/-231) tests/burgers_mms_adjoint/mms_D.bound (+0/-4) tests/burgers_mms_adjoint/mms_D.ele (+0/-802) tests/burgers_mms_adjoint/mms_D.node (+0/-803) tests/burgers_mms_adjoint/mms_E.bml (+0/-231) tests/burgers_mms_adjoint/mms_E.bound (+0/-4) tests/burgers_mms_adjoint/mms_E.ele (+0/-1602) tests/burgers_mms_adjoint/mms_E.node (+0/-1603) tests/burgers_mms_diffusion_adjoint/Makefile (+0/-10) tests/burgers_mms_diffusion_adjoint/burgers.sage (+0/-22) tests/burgers_mms_diffusion_adjoint/burgers_mms_diffusion_adjoint.xml (+0/-149) tests/burgers_mms_diffusion_adjoint/mms_A.bml (+0/-234) tests/burgers_mms_diffusion_adjoint/mms_A.bound (+0/-4) tests/burgers_mms_diffusion_adjoint/mms_A.ele (+0/-102) tests/burgers_mms_diffusion_adjoint/mms_A.node (+0/-103) tests/burgers_mms_diffusion_adjoint/mms_B.bml (+0/-234) tests/burgers_mms_diffusion_adjoint/mms_B.bound (+0/-4) tests/burgers_mms_diffusion_adjoint/mms_B.ele (+0/-202) tests/burgers_mms_diffusion_adjoint/mms_B.node (+0/-203) tests/burgers_mms_diffusion_adjoint/mms_C.bml (+0/-234) tests/burgers_mms_diffusion_adjoint/mms_C.bound (+0/-4) tests/burgers_mms_diffusion_adjoint/mms_C.ele (+0/-402) tests/burgers_mms_diffusion_adjoint/mms_C.node (+0/-403) tests/burgers_mms_diffusion_adjoint/mms_D.bml (+0/-234) tests/burgers_mms_diffusion_adjoint/mms_D.bound (+0/-4) tests/burgers_mms_diffusion_adjoint/mms_D.ele (+0/-802) tests/burgers_mms_diffusion_adjoint/mms_D.node (+0/-803) tests/burgers_mms_diffusion_adjoint/mms_E.bml (+0/-234) tests/burgers_mms_diffusion_adjoint/mms_E.bound (+0/-4) tests/burgers_mms_diffusion_adjoint/mms_E.ele (+0/-1602) tests/burgers_mms_diffusion_adjoint/mms_E.node (+0/-1603) tests/burgers_mms_diffusion_replay/Makefile (+15/-0) tests/burgers_mms_diffusion_replay/burgers.sage (+27/-0) tests/burgers_mms_diffusion_replay/burgers_mms_diffusion_replay.py (+54/-0) tests/burgers_mms_diffusion_replay/burgers_mms_diffusion_replay.xml (+25/-0) tests/burgers_mms_diffusion_replay/mms_A.bml (+200/-0) tests/burgers_mms_diffusion_replay/mms_A.bound (+4/-0) tests/burgers_mms_diffusion_replay/mms_A.ele (+102/-0) tests/burgers_mms_diffusion_replay/mms_A.node (+103/-0) tests/burgers_mms_diffusion_replay/mms_B.bml (+200/-0) tests/burgers_mms_diffusion_replay/mms_B.bound (+4/-0) tests/burgers_mms_diffusion_replay/mms_B.ele (+202/-0) tests/burgers_mms_diffusion_replay/mms_B.node (+203/-0) tests/burgers_mms_diffusion_replay/mms_C.bml (+200/-0) tests/burgers_mms_diffusion_replay/mms_C.bound (+4/-0) tests/burgers_mms_diffusion_replay/mms_C.ele (+402/-0) tests/burgers_mms_diffusion_replay/mms_C.node (+403/-0) tests/burgers_mms_diffusion_replay/mms_D.bml (+200/-0) tests/burgers_mms_diffusion_replay/mms_D.bound (+4/-0) tests/burgers_mms_diffusion_replay/mms_D.ele (+802/-0) tests/burgers_mms_diffusion_replay/mms_D.node (+803/-0) tests/burgers_mms_diffusion_replay/mms_E.bml (+200/-0) tests/burgers_mms_diffusion_replay/mms_E.bound (+4/-0) tests/burgers_mms_diffusion_replay/mms_E.ele (+1602/-0) tests/burgers_mms_diffusion_replay/mms_E.node (+1603/-0) tests/burgers_mms_diffusion_time_integral/burgers_mms_diffusion_time_integral.xml (+17/-15) tests/burgers_mms_diffusion_time_integral/mms_A.bml (+2/-2) tests/burgers_mms_diffusion_time_integral/mms_B.bml (+2/-2) tests/burgers_mms_diffusion_time_integral/mms_C.bml (+2/-2) tests/burgers_mms_diffusion_time_integral/mms_D.bml (+2/-2) tests/burgers_mms_diffusion_time_integral/mms_E.bml (+2/-2) tests/burgers_mms_gaussian/burgers_mms_gaussian.xml (+1/-1) tests/burgers_mms_gaussian_advection/burgers_mms_gaussian_advection.xml (+1/-1) tests/burgers_mms_replay/Makefile (+15/-0) tests/burgers_mms_replay/burgers.sage (+27/-0) tests/burgers_mms_replay/burgers_mms_replay.py (+54/-0) tests/burgers_mms_replay/burgers_mms_replay.xml (+25/-0) tests/burgers_mms_replay/mms_A.bml (+204/-0) tests/burgers_mms_replay/mms_A.bound (+4/-0) tests/burgers_mms_replay/mms_A.ele (+102/-0) tests/burgers_mms_replay/mms_A.node (+103/-0) tests/burgers_mms_replay/mms_B.bml (+204/-0) tests/burgers_mms_replay/mms_B.bound (+4/-0) tests/burgers_mms_replay/mms_B.ele (+202/-0) tests/burgers_mms_replay/mms_B.node (+203/-0) tests/burgers_mms_replay/mms_C.bml (+204/-0) tests/burgers_mms_replay/mms_C.bound (+4/-0) tests/burgers_mms_replay/mms_C.ele (+402/-0) tests/burgers_mms_replay/mms_C.node (+403/-0) tests/burgers_mms_replay/mms_D.bml (+204/-0) tests/burgers_mms_replay/mms_D.bound (+4/-0) tests/burgers_mms_replay/mms_D.ele (+802/-0) tests/burgers_mms_replay/mms_D.node (+803/-0) tests/burgers_mms_replay/mms_E.bml (+204/-0) tests/burgers_mms_replay/mms_E.bound (+4/-0) tests/burgers_mms_replay/mms_E.ele (+1602/-0) tests/burgers_mms_replay/mms_E.node (+1603/-0) tests/burgers_mms_replay/op_A.oml (+26/-0) tests/burgers_mms_steady_adjoint_gradient_init/Makefile (+16/-0) tests/burgers_mms_steady_adjoint_gradient_init/burgers.sage (+11/-0) tests/burgers_mms_steady_adjoint_gradient_init/burgers_mms_steady_adjoint_gradient_init.xml (+25/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_A.bml (+206/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_A.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_A.ele (+102/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_A.node (+103/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_A_controls.bml (+237/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_B.bml (+206/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_B.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_B.ele (+202/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_B.node (+203/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_C.bml (+206/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_C.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_C.ele (+402/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_C.node (+403/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_D.bml (+206/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_D.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_D.ele (+802/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_D.node (+803/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_E.bml (+209/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_E.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_E.ele (+1602/-0) tests/burgers_mms_steady_adjoint_gradient_init/mms_E.node (+1603/-0) tests/burgers_mms_steady_adjoint_gradient_init/op_A.oml (+19/-0) tests/burgers_mms_steady_adjoint_gradient_init/op_B.oml (+19/-0) tests/burgers_mms_steady_adjoint_gradient_init/op_C.oml (+19/-0) tests/burgers_mms_steady_adjoint_gradient_init/op_D.oml (+19/-0) tests/burgers_mms_steady_adjoint_gradient_init/op_E.oml (+19/-0) tests/burgers_mms_steady_adjoint_gradient_src/Makefile (+14/-0) tests/burgers_mms_steady_adjoint_gradient_src/burgers.sage (+11/-0) tests/burgers_mms_steady_adjoint_gradient_src/burgers_mms_steady_adjoint_gradient_src.xml (+36/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_A.bml (+236/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_A.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_A.ele (+102/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_A.node (+103/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_B.bml (+236/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_B.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_B.ele (+202/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_B.node (+203/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_C.bml (+236/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_C.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_C.ele (+402/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_C.node (+403/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_D.bml (+236/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_D.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_D.ele (+802/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_D.node (+803/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_E.bml (+236/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_E.bound (+4/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_E.ele (+1602/-0) tests/burgers_mms_steady_adjoint_gradient_src/mms_E.node (+1603/-0) tests/burgers_mms_steady_adjoint_gradient_src/op_A.oml (+19/-0) tests/burgers_tadj_mms/Makefile (+0/-10) tests/burgers_tadj_mms/adjoint_A.mv (+0/-84) tests/burgers_tadj_mms/adjoint_E.mv (+0/-84) tests/burgers_tadj_mms/burgers.sage (+0/-17) tests/burgers_tadj_mms/burgers_A.mv (+0/-84) tests/burgers_tadj_mms/burgers_tadj_mms.xml (+0/-53) tests/burgers_tadj_mms/mms_A.bml (+0/-251) tests/burgers_tadj_mms/mms_A.bound (+0/-4) tests/burgers_tadj_mms/mms_A.ele (+0/-12) tests/burgers_tadj_mms/mms_A.node (+0/-13) tests/burgers_tadj_mms/mms_B.bml (+0/-251) tests/burgers_tadj_mms/mms_B.bound (+0/-12) tests/burgers_tadj_mms/mms_B.ele (+0/-606) tests/burgers_tadj_mms/mms_B.node (+0/-609) tests/burgers_tadj_mms/mms_C.bml (+0/-251) tests/burgers_tadj_mms/mms_C.bound (+0/-12) tests/burgers_tadj_mms/mms_C.ele (+0/-1206) tests/burgers_tadj_mms/mms_C.node (+0/-1209) tests/burgers_tadj_mms/mms_D.bml (+0/-251) tests/burgers_tadj_mms/mms_D.bound (+0/-12) tests/burgers_tadj_mms/mms_D.ele (+0/-2406) tests/burgers_tadj_mms/mms_D.node (+0/-2409) tests/burgers_tadj_mms/mms_E.bml (+0/-251) tests/burgers_tadj_mms/mms_E.bound (+0/-12) tests/burgers_tadj_mms/mms_E.ele (+0/-4806) tests/burgers_tadj_mms/mms_E.node (+0/-4809) tests/burgers_tadj_nonlin/Makefile (+0/-10) tests/burgers_tadj_nonlin/burgers.sage (+0/-29) tests/burgers_tadj_nonlin/burgers_tadj_nonlin.xml (+0/-84) tests/burgers_tadj_nonlin/mms_A.bml (+0/-321) tests/burgers_tadj_nonlin/mms_A.bound (+0/-4) tests/burgers_tadj_nonlin/mms_A.ele (+0/-12) tests/burgers_tadj_nonlin/mms_A.node (+0/-13) tests/burgers_tadj_nonlin/mms_B.bml (+0/-321) tests/burgers_tadj_nonlin/mms_B.bound (+0/-12) tests/burgers_tadj_nonlin/mms_B.ele (+0/-606) tests/burgers_tadj_nonlin/mms_B.node (+0/-609) tests/burgers_tadj_nonlin/mms_C.bml (+0/-321) tests/burgers_tadj_nonlin/mms_C.bound (+0/-12) tests/burgers_tadj_nonlin/mms_C.ele (+0/-1206) tests/burgers_tadj_nonlin/mms_C.node (+0/-1209) tests/burgers_tadj_nonlin/mms_D.bml (+0/-321) tests/burgers_tadj_nonlin/mms_D.bound (+0/-12) tests/burgers_tadj_nonlin/mms_D.ele (+0/-2406) tests/burgers_tadj_nonlin/mms_D.node (+0/-2409) tests/burgers_tadj_nonlin/mms_E.bml (+0/-321) tests/burgers_tadj_nonlin/mms_E.bound (+0/-12) tests/burgers_tadj_nonlin/mms_E.ele (+0/-4806) tests/burgers_tadj_nonlin/mms_E.node (+0/-4809) tests/burgers_tadj_simple/Makefile (+0/-10) tests/burgers_tadj_simple/burgers.sage (+0/-29) tests/burgers_tadj_simple/burgers_tadj_simple.xml (+0/-84) tests/burgers_tadj_simple/mms_A.bml (+0/-335) tests/burgers_tadj_simple/mms_A.bound (+0/-4) tests/burgers_tadj_simple/mms_A.ele (+0/-12) tests/burgers_tadj_simple/mms_A.node (+0/-13) tests/burgers_tadj_simple/mms_B.bml (+0/-335) tests/burgers_tadj_simple/mms_B.bound (+0/-12) tests/burgers_tadj_simple/mms_B.ele (+0/-606) tests/burgers_tadj_simple/mms_B.node (+0/-609) tests/burgers_tadj_simple/mms_C.bml (+0/-335) tests/burgers_tadj_simple/mms_C.bound (+0/-12) tests/burgers_tadj_simple/mms_C.ele (+0/-1206) tests/burgers_tadj_simple/mms_C.node (+0/-1209) tests/burgers_tadj_simple/mms_D.bml (+0/-335) tests/burgers_tadj_simple/mms_D.bound (+0/-12) tests/burgers_tadj_simple/mms_D.ele (+0/-2406) tests/burgers_tadj_simple/mms_D.node (+0/-2409) tests/burgers_tadj_simple/mms_E.bml (+0/-335) tests/burgers_tadj_simple/mms_E.bound (+0/-12) tests/burgers_tadj_simple/mms_E.ele (+0/-4806) tests/burgers_tadj_simple/mms_E.node (+0/-4809) tests/burgers_tadj_timestep/Makefile (+0/-10) tests/burgers_tadj_timestep/burgers.sage (+0/-30) tests/burgers_tadj_timestep/burgers_tadj_timestep.xml (+0/-84) tests/burgers_tadj_timestep/mms_A.bml (+0/-333) tests/burgers_tadj_timestep/mms_A.bound (+0/-4) tests/burgers_tadj_timestep/mms_A.ele (+0/-12) tests/burgers_tadj_timestep/mms_A.node (+0/-13) tests/burgers_tadj_timestep/mms_B.bml (+0/-333) tests/burgers_tadj_timestep/mms_B.bound (+0/-12) tests/burgers_tadj_timestep/mms_B.ele (+0/-606) tests/burgers_tadj_timestep/mms_B.node (+0/-609) tests/burgers_tadj_timestep/mms_C.bml (+0/-333) tests/burgers_tadj_timestep/mms_C.bound (+0/-12) tests/burgers_tadj_timestep/mms_C.ele (+0/-1206) tests/burgers_tadj_timestep/mms_C.node (+0/-1209) tests/burgers_tadj_timestep/mms_D.bml (+0/-333) tests/burgers_tadj_timestep/mms_D.bound (+0/-12) tests/burgers_tadj_timestep/mms_D.ele (+0/-2406) tests/burgers_tadj_timestep/mms_D.node (+0/-2409) tests/burgers_tadj_timestep/mms_E.bml (+0/-333) tests/burgers_tadj_timestep/mms_E.bound (+0/-12) tests/burgers_tadj_timestep/mms_E.ele (+0/-4806) tests/burgers_tadj_timestep/mms_E.node (+0/-4809) tests/optimality/Makefile (+11/-0) tests/optimality/dummy.swml (+317/-0) tests/optimality/optimality.xml (+67/-0) tests/optimality/optimiser.oml (+68/-0) tests/optimality/src/Makefile (+2/-0) tests/optimality/src/mesh_A.bound (+4/-0) tests/optimality/src/mesh_A.ele (+6/-0) tests/optimality/src/mesh_A.node (+7/-0) tests/saltfinger2d_quad/saltfinger2d_quad.xml (+1/-1) tests/shallow_water_adjoint_default_controls/Makefile (+17/-0) tests/shallow_water_adjoint_default_controls/adjoint_A.swml (+534/-0) tests/shallow_water_adjoint_default_controls/adjoint_controls_convergence_rate.py (+54/-0) tests/shallow_water_adjoint_default_controls/shallow_water_adjoint_default_controls.py (+21/-0) tests/shallow_water_adjoint_default_controls/shallow_water_adjoint_default_controls.xml (+73/-0) tests/shallow_water_adjoint_default_controls/source_terms.py (+28/-0) tests/shallow_water_adjoint_default_controls/source_terms.sage (+25/-0) tests/shallow_water_adjoint_default_controls/src/Makefile (+6/-0) tests/shallow_water_adjoint_default_controls_2d/Makefile (+17/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_A.swml (+549/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_B.swml (+549/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_C.swml (+549/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_D.swml (+546/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_E.swml (+546/-0) tests/shallow_water_adjoint_default_controls_2d/adjoint_controls_convergence_rate_2d.py (+54/-0) tests/shallow_water_adjoint_default_controls_2d/shallow_water_adjoint_default_controls_2d.py (+29/-0) tests/shallow_water_adjoint_default_controls_2d/shallow_water_adjoint_default_controls_2d.xml (+73/-0) tests/shallow_water_adjoint_default_controls_2d/source_terms.py (+29/-0) tests/shallow_water_adjoint_default_controls_2d/source_terms.sage (+26/-0) tests/shallow_water_adjoint_default_controls_2d/src/Makefile (+9/-0) tests/shallow_water_adjoint_default_controls_2d/src/mesh_A.geo (+15/-0) tests/shallow_water_adjoint_default_controls_2d/src/mesh_B.geo (+15/-0) tests/shallow_water_adjoint_default_controls_2d/src/mesh_C.geo (+15/-0) tests/shallow_water_adjoint_eta/adjoint_A.swml (+16/-14) tests/shallow_water_adjoint_eta/shallow_water_adjoint_eta.xml (+5/-5) tests/shallow_water_adjoint_func_eval/shallow_water_adjoint_func_eval.xml (+1/-5) tests/shallow_water_adjoint_func_eval_2d/shallow_water_adjoint_func_eval_2d.xml (+18/-4) tests/shallow_water_adjoint_func_eval_2d/src/mesh_A.msh (+71/-71) tests/shallow_water_adjoint_func_eval_2d/src/mesh_B.msh (+241/-241) tests/shallow_water_adjoint_func_eval_2d/src/mesh_C.msh (+881/-881) tests/shallow_water_adjoint_func_eval_2d/time_integral_2d.py (+0/-8) tests/shallow_water_optimisation/Makefile (+22/-0) tests/shallow_water_optimisation/adjoint_A.swml (+338/-0) tests/shallow_water_optimisation/adjoint_B.swml (+388/-0) tests/shallow_water_optimisation/adjoint_C.swml (+388/-0) tests/shallow_water_optimisation/adjoint_D.swml (+388/-0) tests/shallow_water_optimisation/adjoint_E.swml (+388/-0) tests/shallow_water_optimisation/optimiser_A.oml (+23/-0) tests/shallow_water_optimisation/shallow_water_optimisation.py (+19/-0) tests/shallow_water_optimisation/shallow_water_optimisation.xml (+62/-0) tests/shallow_water_optimisation/source_terms.sage (+25/-0) tests/shallow_water_optimisation/src/Makefile (+6/-0) tests/shallow_water_optimisation/src/mesh_A.bound (+4/-0) tests/shallow_water_optimisation/src/mesh_A.ele (+12/-0) tests/shallow_water_optimisation/src/mesh_A.node (+13/-0) tests/shallow_water_optimisation/src/mesh_B.bound (+4/-0) tests/shallow_water_optimisation/src/mesh_B.ele (+22/-0) tests/shallow_water_optimisation/src/mesh_B.node (+23/-0) tests/shallow_water_optimisation/src/mesh_C.bound (+4/-0) tests/shallow_water_optimisation/src/mesh_C.ele (+42/-0) tests/shallow_water_optimisation/src/mesh_C.node (+43/-0) tests/shallow_water_optimisation/src/mesh_D.bound (+4/-0) tests/shallow_water_optimisation/src/mesh_D.ele (+82/-0) tests/shallow_water_optimisation/src/mesh_D.node (+83/-0) tests/shallow_water_optimisation/src/mesh_E.bound (+4/-0) tests/shallow_water_optimisation/src/mesh_E.ele (+162/-0) tests/shallow_water_optimisation/src/mesh_E.node (+163/-0) tests/shallow_water_optimisation_2d/Makefile (+21/-0) tests/shallow_water_optimisation_2d/adjoint_A.swml (+349/-0) tests/shallow_water_optimisation_2d/adjoint_B.swml (+398/-0) tests/shallow_water_optimisation_2d/adjoint_C.swml (+398/-0) tests/shallow_water_optimisation_2d/adjoint_D.swml (+398/-0) tests/shallow_water_optimisation_2d/adjoint_E.swml (+398/-0) tests/shallow_water_optimisation_2d/constants_2d.py (+27/-0) tests/shallow_water_optimisation_2d/optimiser_A.log (+15/-0) tests/shallow_water_optimisation_2d/optimiser_A.oml (+20/-0) tests/shallow_water_optimisation_2d/optimiser_B.oml (+20/-0) tests/shallow_water_optimisation_2d/optimiser_C.oml (+20/-0) tests/shallow_water_optimisation_2d/optimiser_D.oml (+20/-0) tests/shallow_water_optimisation_2d/optimiser_E.oml (+20/-0) tests/shallow_water_optimisation_2d/shallow_water_optimisation_2d.xml (+62/-0) tests/shallow_water_optimisation_2d/source_terms.py (+25/-0) tests/shallow_water_optimisation_2d/source_terms.sage (+22/-0) tests/shallow_water_optimisation_2d/src/Makefile (+3/-0) tests/shallow_water_optimisation_2d/src/mesh_A.bound (+4/-0) tests/shallow_water_optimisation_2d/src/mesh_A.edge (+38/-0) tests/shallow_water_optimisation_2d/src/mesh_A.ele (+198/-0) tests/shallow_water_optimisation_2d/src/mesh_A.geo (+15/-0) tests/shallow_water_optimisation_2d/src/mesh_A.msh (+358/-0) tests/shallow_water_optimisation_2d/src/mesh_A.node (+119/-0) tests/shallow_water_optimisation_bounds/Makefile (+19/-0) tests/shallow_water_optimisation_bounds/adjoint_A.swml (+378/-0) tests/shallow_water_optimisation_bounds/adjoint_B.swml (+422/-0) tests/shallow_water_optimisation_bounds/adjoint_C.swml (+422/-0) tests/shallow_water_optimisation_bounds/adjoint_D.swml (+422/-0) tests/shallow_water_optimisation_bounds/optimiser_A.oml (+20/-0) tests/shallow_water_optimisation_bounds/optimiser_B.oml (+20/-0) tests/shallow_water_optimisation_bounds/optimiser_C.oml (+20/-0) tests/shallow_water_optimisation_bounds/optimiser_D.oml (+20/-0) tests/shallow_water_optimisation_bounds/shallow_water_optimisation_bounds.py (+19/-0) tests/shallow_water_optimisation_bounds/shallow_water_optimisation_bounds.xml (+63/-0) tests/shallow_water_optimisation_bounds/source_terms.py (+28/-0) tests/shallow_water_optimisation_bounds/source_terms.sage (+25/-0) tests/shallow_water_optimisation_bounds/src/Makefile (+5/-0) tests/shallow_water_optimisation_check_gradient_2d/Makefile (+11/-0) tests/shallow_water_optimisation_check_gradient_2d/adjoint_A.swml (+350/-0) tests/shallow_water_optimisation_check_gradient_2d/constants_2d.py (+27/-0) tests/shallow_water_optimisation_check_gradient_2d/optimiser_A.oml (+26/-0) tests/shallow_water_optimisation_check_gradient_2d/shallow_water_optimisation_check_gradient_2d.xml (+18/-0) tests/shallow_water_optimisation_check_gradient_2d/src/Makefile (+3/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.bound (+4/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.edge (+14/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.ele (+24/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.geo (+15/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.msh (+61/-0) tests/shallow_water_optimisation_check_gradient_2d/src/mesh_A.node (+20/-0) tests/shallow_water_optimisation_sphere/Makefile (+16/-0) tests/shallow_water_optimisation_sphere/constants_2d.py (+33/-0) tests/shallow_water_optimisation_sphere/optimiser_A.oml (+23/-0) tests/shallow_water_optimisation_sphere/shallow_water_optimisation_sphere.xml (+40/-0) tests/shallow_water_optimisation_sphere/source_terms.py (+31/-0) tests/shallow_water_optimisation_sphere/source_terms.sage (+28/-0) tests/shallow_water_optimisation_sphere/src/Makefile (+7/-0) tests/shallow_water_optimisation_sphere/src/sphere_A.geo (+42/-0) tests/shallow_water_optimisation_sphere/src/sphere_B.geo (+42/-0) tests/shallow_water_optimisation_sphere/src/sphere_C.geo (+42/-0) tests/shallow_water_optimisation_sphere/sw_fsphere_A.swml (+471/-0) tests/shallow_water_optimisation_sphere/sw_fsphere_B.swml (+472/-0) tests/shallow_water_optimisation_sphere/sw_fsphere_C.swml (+472/-0) tests/sw_fsphere/sw_fsphere.swml (+1/-1) tests/sw_kelvin_wave/sw_kelvin_wave.xml (+1/-1) tests/sw_kelvin_wave_xz/sw_kelvin_wave_xz.xml (+1/-1) tools/testharness.py (+13/-4) |
To merge this branch: | bzr merge lp:~fluidity-core/fluidity/adjoint |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
David Ham | Approve | ||
Review via email: mp+67670@code.launchpad.net |
Commit message
Description of the change
Overview of the major changes:
-------
* The burgers equation adjoint now works, including nonlinear terms (and so their derivatives). The differentiation of the CG discretisation of the advection term is achieved using tapenade.
* The development of a program (scripts/
* More (and more rigorous) test cases. The fundamental tool for verifying the discrete adjoint is the derivative test, which is implemented in optimality.py. Suppose you can compute J(m), and have a candidate for grad(J)(m). Then
|| J(m + dm) - J(m) || should converge at O(||dm||), and
|| J(m + dm) - J(m) - grad(J)(m) . dm || should converge at O(||dm||^2).
* Much stronger tools for debugging adjoint model development, including
- forward replay verification
- transpose action correctness
- nonlinear derivative consistency
- the derivative test in optimality.py
- 3589. By Patrick Farrell
-
Removing shallow_
water_mms_ sphere: it never worked. Simon: I checked out the commit which added this, and the
test is broken there. If you want this test, revive it,
fix it, and add it back. - 3590. By Patrick Farrell
-
In the shallow water model, we now write_diagnostics before the timeloop
begins. (Simon: why? It was r3521. Something to do with the optimiser?)
So we have to change the test to look at stat[1] instead of stat[0] so that
it is looking at the same thing. - 3591. By Patrick Farrell
-
Loosen some tolerances slightly, and activate two new assertions that had been
broken - 3592. By Patrick Farrell
-
Try to get some useful information out of this test; it is failing on
the buildbot, but works when I run it by hand (on my workstation,
and on the buildbot builder) - 3593. By Patrick Farrell
-
Implement David's suggestions during the code review.
Patrick Farrell (pefarrell) wrote : | # |
Patrick Farrell (pefarrell) wrote : | # |
All tests pass with --with-adjoint=no:
http://
(Ignore the colour and look at the stdio; the buildbot is interpreting it incorrectly.)
Just waiting on the --with-adjoint=yes case.
David Ham (david-ham) : | # |
Patrick Farrell (pefarrell) wrote : | # |
The --with-adjoint case also passes:
http://
The only exception is the channel-flow-dg case, which is known broken in the trunk.
Updating diff...
An updated diff will be available in a few minutes. Reload to see the changes.
Preview Diff
1 | === modified file 'Makefile.in' |
2 | --- Makefile.in 2011-06-27 14:01:01 +0000 |
3 | +++ Makefile.in 2011-07-12 15:56:32 +0000 |
4 | @@ -424,7 +424,7 @@ |
5 | @echo " CLEAN tests" |
6 | @cd tests; ../tools/testharness.py --clean >/dev/null |
7 | |
8 | -test: fltools bin/@FLUIDITY@ bin/shallow_water serialtest |
9 | +test: fltools bin/@FLUIDITY@ bin/shallow_water serialtest bin/burgers_equation |
10 | |
11 | serialtest: |
12 | ifeq (@MBA2D@,yes) |
13 | @@ -441,7 +441,7 @@ |
14 | endif |
15 | endif |
16 | |
17 | -mediumtest: |
18 | +mediumtest: bin/burgers_equation |
19 | @cd tests; ../tools/testharness.py -l medium $(EXCLUDE_TAGS) -n $(THREADS) |
20 | |
21 | mediumzoltantest: |
22 | |
23 | === modified file 'aclocal.m4' |
24 | --- aclocal.m4 2011-02-01 18:21:13 +0000 |
25 | +++ aclocal.m4 2011-07-12 15:56:32 +0000 |
26 | @@ -1030,10 +1030,11 @@ |
27 | [adjoint="$withval"], |
28 | []) |
29 | |
30 | +bakLIBS=$LIBS |
31 | tmpLIBS=$LIBS |
32 | tmpCPPFLAGS=$CPPFLAGS |
33 | -if test $adjoint != no; then |
34 | - if test $adjoint != yes; then |
35 | +if test "$adjoint" != "no"; then |
36 | + if test "$adjoint" != "yes"; then |
37 | adjoint_LIBS_PATH="$adjoint/lib" |
38 | adjoint_INCLUDES_PATH="$adjoint/include" |
39 | # Ensure the comiler finds the library... |
40 | @@ -1051,10 +1052,9 @@ |
41 | AC_CHECK_LIB( |
42 | [adjoint], |
43 | [adj_register_equation], |
44 | - [AC_DEFINE(HAVE_ADJOINT,1,[Define if you have libadjoint.])], |
45 | - [AC_MSG_ERROR( [Could not link in libadjoint ... exiting] )] ) |
46 | + [AC_DEFINE(HAVE_ADJOINT,1,[Define if you have libadjoint.])HAVE_ADJOINT=yes], |
47 | + [AC_MSG_WARN( [Could not link in libadjoint ... ] );HAVE_ADJOINT=no;LIBS=$bakLIBS] ) |
48 | # Save variables... |
49 | AC_LANG_RESTORE |
50 | |
51 | -echo $LIBS |
52 | ])dnl ACX_adjoint |
53 | |
54 | === added file 'adjoint/Adjoint_Controls.F90' |
55 | --- adjoint/Adjoint_Controls.F90 1970-01-01 00:00:00 +0000 |
56 | +++ adjoint/Adjoint_Controls.F90 2011-07-12 15:56:32 +0000 |
57 | @@ -0,0 +1,611 @@ |
58 | +! Copyright (C) 2006 Imperial College London and others. |
59 | +! |
60 | +! Please see the AUTHORS file in the main source directory for a full list |
61 | +! of copyright holders. |
62 | +! |
63 | +! Prof. C Pain |
64 | +! Applied Modelling and Computation Group |
65 | +! Department of Earth Science and Engineering |
66 | +! Imperial College London |
67 | +! |
68 | +! amcgsoftware@imperial.ac.uk |
69 | +! |
70 | +! This library is free software; you can redistribute it and/or |
71 | +! modify it under the terms of the GNU Lesser General Public |
72 | +! License as published by the Free Software Foundation, |
73 | +! version 2.1 of the License. |
74 | +! |
75 | +! This library is distributed in the hope that it will be useful, |
76 | +! but WITHOUT ANY WARRANTY; without even the implied warranty of |
77 | +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
78 | +! Lesser General Public License for more details. |
79 | +! |
80 | +! You should have received a copy of the GNU Lesser General Public |
81 | +! License along with this library; if not, write to the Free Software |
82 | +! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
83 | +! USA |
84 | + |
85 | +#include "fdebug.h" |
86 | + |
87 | +module adjoint_controls |
88 | + use fields |
89 | + use global_parameters, only : PYTHON_FUNC_LEN, OPTION_PATH_LEN |
90 | + use boundary_conditions |
91 | + use spud |
92 | + use state_module |
93 | + use python_state |
94 | + |
95 | + implicit none |
96 | + |
97 | + private |
98 | + |
99 | + public :: adjoint_load_controls, adjoint_write_controls, adjoint_write_control_derivatives, allocate_and_insert_control_derivative_fields |
100 | + |
101 | + contains |
102 | + |
103 | + ! Retrieves the control details from control number control_no in the optin tree. The outputs are: |
104 | + subroutine get_control_details(states, timestep, control_no, control_name, state_id, field_name, field_type, & |
105 | + & active, have_lb, lb_state_id, lb_material_phase_name, lb_field_name, have_ub, & |
106 | + & ub_state_id, ub_material_phase_name, ub_field_name) |
107 | + |
108 | + ! Inputs: |
109 | + type(state_type), dimension(:), intent(in) :: states |
110 | + integer, intent(in) :: control_no, timestep ! control_no: The index of the control in the option tree |
111 | + ! timestep: The timestep |
112 | + |
113 | + ! Outputs: |
114 | + character(len=OPTION_PATH_LEN), intent(out) :: control_name, field_type, field_name ! control_name: the name of the control |
115 | + ! field_name: the name of the associated field |
116 | + ! field_type: the type of the associated field |
117 | + integer, intent(out) :: state_id ! the state number in which the associated control field exists |
118 | + logical, intent(out) :: active ! false if the control is active in this timestep (e.g. InitialConditions for timesteps >0) |
119 | + logical, intent(out), optional :: have_ub, have_lb |
120 | + integer, intent(out), optional :: lb_state_id, ub_state_id |
121 | + character(len=OPTION_PATH_LEN), intent(out), optional :: lb_material_phase_name, ub_material_phase_name |
122 | + character(len=OPTION_PATH_LEN), intent(out), optional :: ub_field_name, lb_field_name |
123 | + |
124 | + integer :: s_idx |
125 | + character(len=OPTION_PATH_LEN) :: control_type, material_phase_name, name |
126 | + type(scalar_field), pointer :: sfield => null(), sfield2 => null() |
127 | + type(vector_field), pointer :: vfield => null(), vfield2 => null() |
128 | + type(tensor_field), pointer :: tfield => null(), tfield2 => null() |
129 | + |
130 | + call get_option("/adjoint/controls/control[" // int2str(control_no) //"]/name", control_name) |
131 | + call get_option("/adjoint/controls/control[" // int2str(control_no) //"]/type/name", control_type) |
132 | + call get_option("/adjoint/controls/control[" // int2str(control_no) //"]/type::" // trim(control_type) // "/field_name", name) |
133 | + |
134 | + s_idx = scan(trim(name), "::") |
135 | + if (s_idx == 0) then |
136 | + FLExit("The control " // trim(control_name) // " uses an invalid field_name. It should be of the form Materialphase::Field") |
137 | + end if |
138 | + material_phase_name = name(1:s_idx - 1) |
139 | + field_name = name(s_idx + 2:len_trim(name)) |
140 | + |
141 | + active = .true. |
142 | + |
143 | + ! Find state associated with the material phase |
144 | + do state_id = 1, size(states) |
145 | + if (trim(states(state_id)%name) == trim(material_phase_name)) then |
146 | + exit |
147 | + end if |
148 | + end do |
149 | + if (.not. trim(states(state_id)%name) == trim(material_phase_name)) then |
150 | + FLExit("Could not find state " // trim(material_phase_name) // " as specified in control " // trim(control_name) // ".") |
151 | + end if |
152 | + |
153 | + select case (trim(control_type)) |
154 | + case ("initial_condition") |
155 | + if (timestep > 0) then |
156 | + active = .false. |
157 | + field_type = '' |
158 | + field_name = '' |
159 | + return |
160 | + endif |
161 | + assert(timestep == 0) |
162 | + if (has_scalar_field(states(state_id), field_name)) then |
163 | + field_type = "scalar" |
164 | + elseif (has_vector_field(states(state_id), field_name)) then |
165 | + field_type = "vector" |
166 | + elseif (has_tensor_field(states(state_id), field_name)) then |
167 | + field_type = "tensor" |
168 | + else |
169 | + ewrite(0, *) "The control field " // trim(field_name) // " specified in control " // trim(control_name) // " is not a field in the state." |
170 | + ewrite(0, *) "The current state is: " |
171 | + call print_state(states(state_id)) |
172 | + FLExit("Check your control's field settings.") |
173 | + end if |
174 | + |
175 | + case ("source_term") |
176 | + if (timestep == 0) then |
177 | + active = .false. |
178 | + field_type = '' |
179 | + field_name = '' |
180 | + return |
181 | + end if |
182 | + |
183 | + if (has_scalar_field(states(state_id), field_name)) then |
184 | + field_type = "scalar" |
185 | + elseif (has_vector_field(states(state_id), field_name)) then |
186 | + field_type = "vector" |
187 | + elseif (has_tensor_field(states(state_id), field_name)) then |
188 | + field_type = "tensor" |
189 | + else |
190 | + ewrite(0, *) "The control field " // trim(name) // " specified in control " // trim(control_name) // & |
191 | + & " is not a field in state " // trim(material_phase_name) // "." |
192 | + ewrite(0, *) "The current state is: " |
193 | + call print_state(states(state_id)) |
194 | + FLExit("Check your control's field settings.") |
195 | + end if |
196 | + |
197 | + case ("boundary_condition") |
198 | + FLAbort("Boundary condition control not implemented yet.") |
199 | + end select |
200 | + |
201 | + !!!! Check bounds settings !!!! |
202 | + ! We only execute this when the optional files are present |
203 | + if (.not. present(have_lb) .or. .not. present(have_ub)) then |
204 | + return |
205 | + endif |
206 | + |
207 | + have_ub = have_option("/adjoint/controls/control[0]/bounds/upper_bound") |
208 | + have_ub = have_option("/adjoint/controls/control[" // int2str(control_no) //"]/bounds/upper_bound") |
209 | + have_lb = have_option("/adjoint/controls/control[" // int2str(control_no) //"]/bounds/lower_bound") |
210 | + |
211 | + ! Find material phase for the lower bound field |
212 | + if (have_lb) then |
213 | + call get_option("/adjoint/controls/control[" // int2str(control_no) //"]/bounds/lower_bound/field_name", name) |
214 | + if (have_lb) then |
215 | + s_idx = scan(trim(name), "::") |
216 | + if (s_idx == 0) then |
217 | + FLExit("The control lower bound for control " // trim(control_name) // " uses an invalid field_name. It should be of the form Materialphase::Field") |
218 | + end if |
219 | + lb_material_phase_name = name(1:s_idx - 1) |
220 | + lb_field_name = name(s_idx + 2:len_trim(name)) |
221 | + ! Find state associated with the lower bound material phase |
222 | + do lb_state_id = 1, size(states) |
223 | + if (trim(states(lb_state_id)%name) == trim(lb_material_phase_name)) then |
224 | + exit |
225 | + end if |
226 | + end do |
227 | + if (.not. trim(states(lb_state_id)%name) == trim(lb_material_phase_name)) then |
228 | + FLExit("Could not find state " // trim(lb_material_phase_name) // " as specified in the lower bound of control " // trim(control_name) // ".") |
229 | + end if |
230 | + end if |
231 | + end if |
232 | + |
233 | + ! Find material phase for the upper bound field |
234 | + if (have_ub) then |
235 | + call get_option("/adjoint/controls/control[" // int2str(control_no) //"]/bounds/upper_bound/field_name", name) |
236 | + if (have_ub) then |
237 | + s_idx = scan(trim(name), "::") |
238 | + if (s_idx == 0) then |
239 | + FLExit("The control upper bound for control " // trim(control_name) // " uses an invalid field_name. It should be of the form Materialphase::Field") |
240 | + end if |
241 | + ub_material_phase_name = name(1:s_idx - 1) |
242 | + ub_field_name = name(s_idx + 2:len_trim(name)) |
243 | + ! Find state associated with the upper bound material phase |
244 | + do ub_state_id = 1, size(states) |
245 | + if (trim(states(ub_state_id)%name) == trim(ub_material_phase_name)) then |
246 | + exit |
247 | + end if |
248 | + end do |
249 | + if (.not. trim(states(ub_state_id)%name) == trim(ub_material_phase_name)) then |
250 | + FLExit("Could not find state " // trim(ub_material_phase_name) // " as specified in the upper bound of control " // trim(control_name) // ".") |
251 | + end if |
252 | + end if |
253 | + end if |
254 | + |
255 | + ! Check that the lower/upper bound fields indeed exist and have the same mesh than the control |
256 | + select case (trim(field_type)) |
257 | + |
258 | + case ("scalar") |
259 | + ! Upper bound |
260 | + ! Check that the specified field exist in the state |
261 | + if (have_ub) then |
262 | + if (.not. has_scalar_field(states(ub_state_id), ub_field_name)) then |
263 | + ewrite(0, *) "Can not find the specified field ", trim(ub_field_name), " for the upper bound of control ", trim(control_name) |
264 | + FLExit("Check your control's field settings.") |
265 | + end if |
266 | + |
267 | + ! Check that the control and the upper bound use the same mesh |
268 | + sfield => extract_scalar_field(states(state_id), field_name) |
269 | + sfield2 => extract_scalar_field(states(ub_state_id), ub_field_name) |
270 | + if (.not. sfield%mesh == sfield2%mesh) then |
271 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The upper bound and the control's mesh have to be the same." |
272 | + FLExit("Check your control's field settings.") |
273 | + end if |
274 | + end if |
275 | + |
276 | + ! Lower bound |
277 | + if (have_lb) then |
278 | + if (.not. has_scalar_field(states(state_id), lb_field_name)) then |
279 | + ewrite(0, *) "Can not find the specified field ", trim(lb_field_name), " for the lower bound of control ", trim(control_name) |
280 | + FLExit("Check your control's field settings.") |
281 | + end if |
282 | + |
283 | + ! Check that the control and the lower bound use the same mesh |
284 | + sfield => extract_scalar_field(states(state_id), field_name) |
285 | + sfield2 => extract_scalar_field(states(lb_state_id), lb_field_name) |
286 | + if (.not. sfield%mesh == sfield2%mesh) then |
287 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The lower bound and the control's mesh have to be the same." |
288 | + FLExit("Check your control's field settings.") |
289 | + end if |
290 | + end if |
291 | + |
292 | + case ("vector") |
293 | + ! Upper bound |
294 | + ! Check that the specified field exist in the state |
295 | + if (have_ub) then |
296 | + if (.not. has_vector_field(states(ub_state_id), ub_field_name)) then |
297 | + ewrite(0, *) "Can not find the specified field ", trim(ub_field_name), " for the upper bound of control ", trim(control_name) |
298 | + FLExit("Check your control's field settings.") |
299 | + end if |
300 | + |
301 | + ! Check that the control and the upper bound use the same mesh |
302 | + vfield => extract_vector_field(states(state_id), field_name) |
303 | + vfield2 => extract_vector_field(states(ub_state_id), ub_field_name) |
304 | + if (.not. vfield%mesh == vfield2%mesh) then |
305 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The upper bound and the control's mesh have to be the same." |
306 | + FLExit("Check your control's field settings.") |
307 | + end if |
308 | + end if |
309 | + |
310 | + ! Lower bound |
311 | + if (have_lb) then |
312 | + if (.not. has_vector_field(states(state_id), lb_field_name)) then |
313 | + ewrite(0, *) "Can not find the specified field ", trim(lb_field_name), " for the lower bound of control ", trim(control_name) |
314 | + FLExit("Check your control's field settings.") |
315 | + end if |
316 | + |
317 | + ! Check that the control and the lower bound use the same mesh |
318 | + vfield => extract_vector_field(states(state_id), field_name) |
319 | + vfield2 => extract_vector_field(states(lb_state_id), lb_field_name) |
320 | + if (.not. vfield%mesh == vfield2%mesh) then |
321 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The lower bound and the control's mesh have to be the same." |
322 | + FLExit("Check your control's field settings.") |
323 | + end if |
324 | + end if |
325 | + |
326 | + case ("tensor") |
327 | + ! Upper bound |
328 | + ! Check that the specified field exist in the state |
329 | + if (have_ub) then |
330 | + if (.not. has_tensor_field(states(ub_state_id), ub_field_name)) then |
331 | + ewrite(0, *) "Can not find the specified field ", trim(ub_field_name), " for the upper bound of control ", trim(control_name) |
332 | + FLExit("Check your control's field settings.") |
333 | + end if |
334 | + |
335 | + ! Check that the control and the upper bound use the same mesh |
336 | + tfield => extract_tensor_field(states(state_id), field_name) |
337 | + tfield2 => extract_tensor_field(states(ub_state_id), ub_field_name) |
338 | + if (.not. tfield%mesh == tfield2%mesh) then |
339 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The lower bound and the control's mesh have to be the same." |
340 | + FLExit("Check your control's field settings.") |
341 | + end if |
342 | + end if |
343 | + |
344 | + ! Lower bound |
345 | + if (have_lb) then |
346 | + if (.not. has_tensor_field(states(state_id), lb_field_name)) then |
347 | + ewrite(0, *) "Can not find the specified field ", trim(lb_field_name), " for the lower bound of control ", trim(control_name) |
348 | + FLExit("Check your control's field settings.") |
349 | + end if |
350 | + |
351 | + ! Check that the control and the lower bound use the same mesh |
352 | + tfield => extract_tensor_field(states(state_id), field_name) |
353 | + tfield2 => extract_tensor_field(states(lb_state_id), lb_field_name) |
354 | + if (.not. sfield%mesh == sfield2%mesh) then |
355 | + ewrite(0, *) "Error in control ", trim(control_name), " definition. The lower bound and the control's mesh have to be the same." |
356 | + FLExit("Check your control's field settings.") |
357 | + end if |
358 | + end if |
359 | + |
360 | + end select |
361 | + end subroutine get_control_details |
362 | + |
363 | + ! Loop through all controls in the option file and store them in files. |
364 | + subroutine adjoint_write_controls(timestep, dt, states) |
365 | + integer, intent(in) :: timestep |
366 | + real, intent(in) :: dt |
367 | + type(state_type), dimension(:), intent(in) :: states |
368 | +#ifdef HAVE_ADJOINT |
369 | + integer :: nb_controls, i, state_id |
370 | + logical :: active |
371 | + character(len=OPTION_PATH_LEN) :: simulation_name, field_name, field_type, control_name |
372 | + logical :: have_ub, have_lb |
373 | + integer :: lb_state_id, ub_state_id |
374 | + character(len=OPTION_PATH_LEN) :: lb_material_phase_name, ub_material_phase_name |
375 | + character(len=OPTION_PATH_LEN) :: ub_field_name, lb_field_name |
376 | + |
377 | + if (.not. have_option("/adjoint/controls")) then |
378 | + return |
379 | + end if |
380 | + |
381 | + nb_controls = option_count("/adjoint/controls/control") |
382 | + call get_option("/simulation_name", simulation_name) |
383 | + ! Now loop over the controls and save them to disk |
384 | + do i = 0, nb_controls-1 |
385 | + call get_control_details(states, timestep, i, control_name, state_id, field_name, field_type, active, have_lb, lb_state_id, lb_material_phase_name, lb_field_name, have_ub, ub_state_id, ub_material_phase_name, ub_field_name) |
386 | + if (active) then |
387 | + |
388 | + ! Save the control parameter to disk |
389 | + call python_reset() |
390 | + call python_add_state(states(state_id)) |
391 | + call python_run_string("import pickle;" // & |
392 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_name) // "_" // int2str(timestep) // ".pkl';" // & |
393 | + & "f = open(fname, 'wb');" // & |
394 | + & "field = state." // trim(field_type) // "_fields['" // trim(field_name) // "'];" // & |
395 | + & "pickle.dump(field.val[:], f);" // & |
396 | + & "f.close();") |
397 | + |
398 | + ! And its bounds |
399 | + call python_reset() |
400 | + if (have_lb) then |
401 | + call python_add_state(states(lb_state_id)) |
402 | + call python_run_string("import pickle;" // & |
403 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_name) // "_lower_bound_" // int2str(timestep) // ".pkl';" // & |
404 | + & "f = open(fname, 'wb');" // & |
405 | + & "field = state." // trim(field_type) // "_fields['" // trim(lb_field_name) // "'];" // & |
406 | + & "pickle.dump(field.val[:], f);" // & |
407 | + & "f.close();") |
408 | + call python_reset() |
409 | + end if |
410 | + |
411 | + if (have_ub) then |
412 | + call python_add_state(states(ub_state_id)) |
413 | + call python_run_string("import pickle;" // & |
414 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_name) // "_upper_bound_" // int2str(timestep) // ".pkl';" // & |
415 | + & "f = open(fname, 'wb');" // & |
416 | + & "field = state." // trim(field_type) // "_fields['" // trim(ub_field_name) // "'];" // & |
417 | + & "pickle.dump(field.val[:], f);" // & |
418 | + & "f.close();") |
419 | + call python_reset() |
420 | + endif |
421 | + |
422 | + end if |
423 | + end do |
424 | +#endif |
425 | + end subroutine adjoint_write_controls |
426 | + |
427 | + ! The counterpart of adjoint_write_controls: Loop through all controls in the option file and fill the fields from the control files. |
428 | + subroutine adjoint_load_controls(timestep, dt, states) |
429 | + integer, intent(in) :: timestep |
430 | + real, intent(in) :: dt |
431 | + type(state_type), dimension(:), intent(in) :: states |
432 | +#ifdef HAVE_ADJOINT |
433 | + integer :: nb_controls, i, state_id, s_idx |
434 | + logical :: active, file_exists |
435 | + character(len=OPTION_PATH_LEN) :: field_name, field_type, control_name, simulation_name, control_type |
436 | + |
437 | + ! Do not read anything if we are supposed to write the controls |
438 | + if (.not. have_option("/adjoint/controls/load_controls")) then |
439 | + return |
440 | + end if |
441 | + |
442 | + call get_option("/simulation_name", simulation_name) |
443 | + nb_controls = option_count("/adjoint/controls/control") |
444 | + |
445 | + ! Now loop over the controls, read their controls files and fill the associated fields |
446 | + do i = 0, nb_controls-1 |
447 | + call get_control_details(states, timestep, i, control_name, state_id, field_name, field_type, active) |
448 | + call get_option("/adjoint/controls/control[" // int2str(i) // "]/type/name", control_type) |
449 | + |
450 | + ! We load all OTHER controls, then apply our strong boundary conditions, then load BC controls |
451 | + if (trim(control_type) == "boundary_condition") cycle |
452 | + |
453 | + if (active) then |
454 | + ! Check that the control parameter file extists |
455 | + inquire(file="control_" // trim(simulation_name) // "_" // trim(control_name) // "_" // int2str(timestep) // ".pkl", exist=file_exists) |
456 | + if (.not. file_exists) then |
457 | + ewrite (0, *) "File 'control_" // trim(simulation_name) // "_" // trim(control_name) // & |
458 | + & "_" // int2str(timestep) // ".pkl' does not exist." |
459 | + FLExit("Error while loading control files. You might want to remove '/adjoint/controls/load_controls'?") |
460 | + end if |
461 | + ! Read the control parameter from disk |
462 | + call python_reset() |
463 | + call python_add_state(states(state_id)) |
464 | + call python_run_string("import pickle;" // & |
465 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_name) // "_" // int2str(timestep) // ".pkl';" // & |
466 | + & "f = open(fname, 'rb');" // & |
467 | + & "field = state." // trim(field_type) // "_fields['" // trim(field_name) // "'];" // & |
468 | + & "field.val[:] = pickle.load(f);" // & |
469 | + & "f.close();") |
470 | + call python_reset() |
471 | + end if |
472 | + end do |
473 | + |
474 | + ! Now apply the BCs, because the BCs should overwrite (say) an initial_condition control |
475 | + call set_dirichlet_consistent(states) |
476 | + |
477 | + do i = 0, nb_controls-1 |
478 | + call get_control_details(states, timestep, i, control_name, state_id, field_name, field_type, active) |
479 | + call get_option("/adjoint/controls/control[" // int2str(i) // "]/type/name", control_type) |
480 | + |
481 | + ! We load all OTHER controls, then apply our strong boundary conditions, then load BC controls |
482 | + if (trim(control_type) /= "boundary_condition") cycle |
483 | + |
484 | + if (active) then |
485 | + ! Check that the control parameter file extists |
486 | + inquire(file="control_" // trim(simulation_name) // "_" // trim(control_name) // "_" // int2str(timestep) // ".pkl", exist=file_exists) |
487 | + if (.not. file_exists) then |
488 | + ewrite (0, *) "File 'control_" // trim(simulation_name) // "_" // trim(control_name) // & |
489 | + & "_" // int2str(timestep) // ".pkl' does not exist." |
490 | + FLExit("Error while loading control files. You might want to remove '/adjoint/controls/load_controls'?") |
491 | + end if |
492 | + ! Read the control parameter from disk |
493 | + call python_reset() |
494 | + call python_add_state(states(state_id)) |
495 | + call python_run_string("import pickle;" // & |
496 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_name) // "_" // int2str(timestep) // ".pkl';" // & |
497 | + & "f = open(fname, 'rb');" // & |
498 | + & "field = state." // trim(field_type) // "_fields['" // trim(field_name) // "'];" // & |
499 | + & "field.val[:] = pickle.load(f);" // & |
500 | + & "f.close();") |
501 | + call python_reset() |
502 | + end if |
503 | + end do |
504 | +#endif |
505 | + end subroutine adjoint_load_controls |
506 | + |
507 | + ! Extracts the total derivatives of the functional and saves them to disk. |
508 | + subroutine adjoint_write_control_derivatives(states, timestep, functional_name) |
509 | + type(state_type), dimension(:), intent(inout) :: states |
510 | + integer, intent(in) :: timestep |
511 | + character(len=*), intent(in) :: functional_name |
512 | + character(len=OPTION_PATH_LEN) :: field_name, control_type, control_deriv_name, field_deriv_name, name, material_phase_name, simulation_name, field_type |
513 | + integer :: nb_controls |
514 | + integer :: i, state_id, s_idx |
515 | + type(scalar_field), pointer :: sfield => null() |
516 | + type(vector_field), pointer :: vfield => null() |
517 | + type(tensor_field), pointer :: tfield => null() |
518 | + |
519 | + if (.not. have_option("/adjoint/controls")) then |
520 | + return |
521 | + end if |
522 | + call get_option("/simulation_name", simulation_name) |
523 | + ! Remove the suffix _adjoint from the simulation_name |
524 | + |
525 | + nb_controls = option_count("/adjoint/controls/control") |
526 | + do i = 0, nb_controls-1 |
527 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/name", control_deriv_name) |
528 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type/name", control_type) |
529 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type::" // trim(control_type) // "/field_name", name) |
530 | + s_idx = scan(trim(name), "::") |
531 | + if (s_idx == 0) then |
532 | + FLExit("The control " // trim(control_deriv_name) // " uses an invalid field_name. It should be of the form Materialphase::Fieldname") |
533 | + end if |
534 | + material_phase_name = name(1:s_idx - 1) |
535 | + field_name = name(s_idx + 2:len_trim(name)) |
536 | + ! Find state associated with the material phase |
537 | + do state_id = 1, size(states) |
538 | + if (trim(states(state_id)%name) == trim(material_phase_name)) then |
539 | + exit |
540 | + end if |
541 | + end do |
542 | + ! Make sure we found the state |
543 | + if (.not. trim(states(state_id)%name) == trim(material_phase_name)) then |
544 | + FLExit("Could not find state " // trim(material_phase_name) // " as specified in control " // trim(control_deriv_name) // ".") |
545 | + end if |
546 | + |
547 | + field_name = "Adjoint" // trim(field_name) |
548 | + control_deriv_name = trim(control_deriv_name) // "_TotalDerivative" |
549 | + if (trim(control_type) == "initial_condition" .or. trim(control_type) == "source_term") then |
550 | + |
551 | + if (trim(control_type) == "initial_condition" .and. timestep > 0) then |
552 | + cycle |
553 | + end if |
554 | + |
555 | + if (trim(control_type) == "source_term" .and. timestep == 0) then |
556 | + cycle |
557 | + end if |
558 | + |
559 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
560 | + if (has_scalar_field(states(state_id), field_name)) then |
561 | + field_type = "scalar" |
562 | + elseif (has_vector_field(states(state_id), field_name)) then |
563 | + field_type = "vector" |
564 | + elseif (has_tensor_field(states(state_id), field_name)) then |
565 | + field_type = "tensor" |
566 | + else |
567 | + ewrite(0, *) "The control field " // trim(field_deriv_name) // " specified in control " // trim(control_deriv_name) // " is not a field in the state." |
568 | + ewrite(0, *) "The current state is: " |
569 | + call print_state(states(state_id)) |
570 | + FLExit("Check your control's field settings.") |
571 | + end if |
572 | + elseif (trim(control_type) == "boundary_condition") then |
573 | + FLAbort("Boundary condition control not implemented yet.") |
574 | + end if |
575 | + ! Save the control parameter to disk |
576 | + call python_reset() |
577 | + call python_add_state(states(state_id)) |
578 | + call python_run_string("import pickle;" // & |
579 | + & "fname = 'control_" // trim(simulation_name) // "_" // trim(control_deriv_name) // "_" // int2str(timestep) // ".pkl';" // & |
580 | + & "f = open(fname, 'wb');" // & |
581 | + & "field = state." // trim(field_type) // "_fields['" // trim(field_deriv_name) // "'];" // & |
582 | + & "pickle.dump(field.val[:], f);" // & |
583 | + & "f.close();") |
584 | + call python_reset() |
585 | + end do |
586 | + end subroutine adjoint_write_control_derivatives |
587 | + |
588 | + subroutine allocate_and_insert_control_derivative_fields(states) |
589 | + type(state_type), dimension(:), intent(inout) :: states |
590 | + integer :: nb_controls, nb_functionals, i, state_id, functional, s_idx |
591 | + character(len=OPTION_PATH_LEN) :: field_name, control_type, control_deriv_name, functional_name, field_deriv_name, material_phase_name, name |
592 | + type(scalar_field), pointer :: sfield => null() |
593 | + type(vector_field), pointer :: vfield => null() |
594 | + type(tensor_field), pointer :: tfield => null() |
595 | + type(scalar_field) :: sfield_deriv |
596 | + type(vector_field) :: vfield_deriv |
597 | + type(tensor_field) :: tfield_deriv |
598 | + |
599 | + nb_controls = option_count("/adjoint/controls/control") |
600 | + nb_functionals = option_count("/adjoint/functional") |
601 | + ! Loop over the functionals |
602 | + do functional = 0, nb_functionals-1 |
603 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
604 | + ! Now loop over the controls |
605 | + do i = 0, nb_controls-1 |
606 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/name", control_deriv_name) |
607 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type/name", control_type) |
608 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type::" // trim(control_type) // "/field_name", name) |
609 | + s_idx = scan(trim(name), "::") |
610 | + if (s_idx == 0) then |
611 | + FLExit("The control " // trim(control_deriv_name) // " uses an invalid field_name. It should be of the form Materialphase::Fieldname") |
612 | + end if |
613 | + material_phase_name = name(1:s_idx - 1) |
614 | + field_name = name(s_idx + 2:len_trim(name)) |
615 | + ! Find state associated with the material phase |
616 | + do state_id = 1, size(states) |
617 | + if (trim(states(state_id)%name) == trim(material_phase_name)) then |
618 | + exit |
619 | + end if |
620 | + end do |
621 | + ! Make sure we found the state |
622 | + if (.not. trim(states(state_id)%name) == trim(material_phase_name)) then |
623 | + FLExit("Could not find state " // trim(material_phase_name) // " as specified in control " // trim(control_deriv_name) // ".") |
624 | + end if |
625 | + |
626 | + field_name = "Adjoint" // trim(field_name) |
627 | + control_deriv_name = trim(control_deriv_name) // "_TotalDerivative" |
628 | + |
629 | + if (trim(control_type) == "initial_condition" .or. trim(control_type) == "source_term") then |
630 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
631 | + |
632 | + if (has_scalar_field(states(state_id), field_name)) then |
633 | + sfield => extract_scalar_field(states(state_id), field_name) |
634 | + call allocate(sfield_deriv, sfield%mesh, field_deriv_name) |
635 | + call zero(sfield_deriv) |
636 | + call insert(states(state_id), sfield_deriv, field_deriv_name) |
637 | + call deallocate(sfield_deriv) |
638 | + |
639 | + elseif (has_vector_field(states(state_id), field_name)) then |
640 | + vfield => extract_vector_field(states(state_id), field_name) |
641 | + call allocate(vfield_deriv, vfield%dim, vfield%mesh, field_deriv_name) |
642 | + call zero(vfield_deriv) |
643 | + call insert(states(state_id), vfield_deriv, field_deriv_name) |
644 | + call deallocate(vfield_deriv) |
645 | + |
646 | + elseif (has_tensor_field(states(state_id), field_name)) then |
647 | + tfield => extract_tensor_field(states(state_id), field_name) |
648 | + call allocate(tfield_deriv, tfield%mesh, field_deriv_name, tfield%field_type, tfield%dim) |
649 | + call zero(tfield_deriv) |
650 | + call insert(states(state_id), tfield_deriv, field_deriv_name) |
651 | + call deallocate(tfield_deriv) |
652 | + |
653 | + else |
654 | + ewrite(0, *) "The control field " // trim(field_name) // " specified in control " // trim(control_deriv_name) // " is not a field in the state." |
655 | + ewrite(0, *) "The current state is: " |
656 | + call print_state(states(state_id)) |
657 | + FLExit("Check your control's field settings.") |
658 | + end if |
659 | + |
660 | + elseif (trim(control_type) == "boundary_condition") then |
661 | + FLAbort("Boundary condition control not implemented yet.") |
662 | + end if |
663 | + |
664 | + end do |
665 | + end do |
666 | + end subroutine allocate_and_insert_control_derivative_fields |
667 | + |
668 | +end module adjoint_controls |
669 | |
670 | === modified file 'adjoint/Adjoint_Functional_Evaluation.F90' |
671 | --- adjoint/Adjoint_Functional_Evaluation.F90 2011-05-20 17:42:50 +0000 |
672 | +++ adjoint/Adjoint_Functional_Evaluation.F90 2011-07-12 15:56:32 +0000 |
673 | @@ -48,7 +48,7 @@ |
674 | implicit none |
675 | |
676 | private |
677 | - public :: libadjoint_functional_derivative, adj_record_anything_necessary |
678 | + public :: libadjoint_evaluate_functional, libadjoint_functional_derivative, adj_record_anything_necessary |
679 | |
680 | contains |
681 | |
682 | @@ -250,32 +250,6 @@ |
683 | end if |
684 | |
685 | if (has_func) then |
686 | - if (.not. functional_computed) then |
687 | - ierr = adj_timestep_get_times(adjointer, timelevel, start_time, end_time) |
688 | - call adj_chkierr(ierr) |
689 | - assert(start_time < end_time) |
690 | - |
691 | - write(buffer,*) timelevel + 1 |
692 | - call python_run_string("n = " // trim(buffer)) |
693 | - |
694 | - write(buffer,*) start_time |
695 | - call python_run_string("time = " // trim(buffer)) |
696 | - |
697 | - write(buffer, *) abs(start_time - end_time) |
698 | - call python_run_string("dt = " // trim(buffer)) |
699 | - |
700 | - call python_run_string(trim(code_func)) |
701 | - J = python_fetch_real("J") |
702 | - |
703 | - ! So we've computed the component of the functional associated with this timestep. |
704 | - ! We also want to sum them all up ... |
705 | - |
706 | - call set_diagnostic(name=trim(functional_name_f) // "_component", statistic="value", value=(/J/)) |
707 | - fn_value => get_diagnostic(name=trim(functional_name_f), statistic="value") |
708 | - J = J + fn_value(1) |
709 | - call set_diagnostic(name=trim(functional_name_f), statistic="value", value=(/J/)) |
710 | - functional_computed = .true. |
711 | - end if |
712 | |
713 | if (.not. has_deriv) then |
714 | check_uncertainties = "try: " // achar(10) // & |
715 | @@ -341,6 +315,111 @@ |
716 | |
717 | end subroutine libadjoint_functional_derivative |
718 | |
719 | + subroutine libadjoint_evaluate_functional(adjointer, timelevel, ndepends, dependencies, values, functional_name_c, output) bind(c) |
720 | + use iso_c_binding |
721 | + use libadjoint_data_structures |
722 | + type(adj_adjointer), intent(in) :: adjointer |
723 | + integer(kind=c_int), intent(in), value :: timelevel |
724 | + integer(kind=c_int), intent(in), value :: ndepends |
725 | + type(adj_variable), dimension(ndepends), intent(in) :: dependencies |
726 | + type(adj_vector), dimension(ndepends), intent(in) :: values |
727 | + character(kind=c_char), dimension(ADJ_NAME_LEN), intent(in) :: functional_name_c |
728 | + adj_scalar_f, intent(out) :: output |
729 | + |
730 | + type(state_type), dimension(:,:), pointer :: states ! material_phases x timelevels |
731 | + character(len=ADJ_NAME_LEN) :: functional_name_f |
732 | + logical :: has_func |
733 | + character(len=PYTHON_FUNC_LEN) :: code_func |
734 | + integer :: ierr, max_timelevel, tmp_timelevel, min_timelevel, nmaterial_phases |
735 | + character(len=OPTION_PATH_LEN) :: material_phase_name |
736 | + integer :: no_timesteps, timestep, i |
737 | + real :: start_time, end_time |
738 | + character(len = 30) :: buffer, buffer2 |
739 | + |
740 | + call python_reset |
741 | + |
742 | + functional_name_f = ' ' |
743 | + i = 1 |
744 | + do while (i <= ADJ_NAME_LEN .and. functional_name_c(i) /= c_null_char) |
745 | + functional_name_f(i:i) = functional_name_c(i) |
746 | + i = i + 1 |
747 | + end do |
748 | + |
749 | + ! Fetch the python code the user has helpfully supplied. |
750 | + has_func = have_option("/adjoint/functional::" // trim(functional_name_f) // "/functional_value/algorithm") |
751 | + if (.not. has_func) then |
752 | + FLAbort("You need to supply code for the functional to evaluate it!") |
753 | + endif |
754 | + |
755 | + if (has_func) then |
756 | + call get_option("/adjoint/functional::" // trim(functional_name_f) // "/functional_value/algorithm", code_func) |
757 | + endif |
758 | + |
759 | + if (ndepends==0) then |
760 | + max_timelevel = 0 |
761 | + min_timelevel = 0 |
762 | + else |
763 | + ! Convert from the list of adj_values/adj_vectors to actual states |
764 | + ierr = adj_variable_get_timestep(dependencies(1), max_timelevel) |
765 | + min_timelevel = max_timelevel |
766 | + do i=1,ndepends |
767 | + ierr = adj_variable_get_timestep(dependencies(i), tmp_timelevel) |
768 | + max_timelevel = max(max_timelevel, tmp_timelevel) |
769 | + min_timelevel = min(min_timelevel, tmp_timelevel) |
770 | + end do |
771 | + end if |
772 | + |
773 | + nmaterial_phases = option_count("/material_phase") |
774 | + allocate(states(nmaterial_phases, min_timelevel:max_timelevel)) |
775 | + |
776 | + ! Set the names of the material phases, so that we can look them up and know |
777 | + ! which material_phase to put stuff into in convert_adj_vectors_to_states |
778 | + do i=0,nmaterial_phases-1 |
779 | + call get_option("/material_phase[" // int2str(i) // "]/name", material_phase_name) |
780 | + states(i+1,:)%name = trim(material_phase_name) |
781 | + end do |
782 | + call convert_adj_vectors_to_states(dependencies, values, states) |
783 | + call python_add_states_time(states) |
784 | + |
785 | + ! Also set up some useful variables for the user to use |
786 | + ierr = adj_timestep_count(adjointer, no_timesteps) |
787 | + call adj_chkierr(ierr) |
788 | + write(buffer, *) no_timesteps |
789 | + call python_run_string("times = [0] * " // trim(buffer)) |
790 | + do timestep=0,no_timesteps-2 |
791 | + ierr = adj_timestep_get_times(adjointer, timestep, start_time, end_time) |
792 | + call adj_chkierr(ierr) |
793 | + write(buffer, '(i0)') timestep |
794 | + write(buffer2, *) start_time |
795 | + call python_run_string("times[" // trim(buffer) // "] = " // trim(buffer2)) |
796 | + write(buffer, '(i0)') timestep+1 |
797 | + write(buffer2, *) end_time |
798 | + call python_run_string("times[" // trim(buffer) // "] = " // trim(buffer2)) |
799 | + end do |
800 | + |
801 | + ierr = adj_timestep_get_times(adjointer, timelevel, start_time, end_time) |
802 | + call adj_chkierr(ierr) |
803 | + assert(start_time < end_time) |
804 | + |
805 | + write(buffer,*) timelevel + 1 |
806 | + call python_run_string("n = " // trim(buffer)) |
807 | + |
808 | + write(buffer,*) start_time |
809 | + call python_run_string("time = " // trim(buffer)) |
810 | + |
811 | + write(buffer, *) abs(start_time - end_time) |
812 | + call python_run_string("dt = " // trim(buffer)) |
813 | + |
814 | + call python_run_string(trim(code_func)) |
815 | + output = python_fetch_real("J") |
816 | + |
817 | + if (max_timelevel >= 0) then |
818 | + call deallocate(states) |
819 | + deallocate(states) |
820 | + endif |
821 | + |
822 | + end subroutine libadjoint_evaluate_functional |
823 | + |
824 | subroutine convert_adj_vectors_to_states(dependencies, values, states) |
825 | type(adj_variable), dimension(:), intent(in) :: dependencies |
826 | type(adj_vector), dimension(:), intent(in) :: values |
827 | @@ -432,7 +511,7 @@ |
828 | call get_option("/timestepping/finish_time", finish_time) |
829 | |
830 | call get_option("/adjoint/functional::" // trim(functional) // "/functional_dependencies/algorithm", buf) |
831 | - call adj_variables_from_python(buf, current_time, finish_time, python_timestep, vars) |
832 | + call adj_variables_from_python(adjointer, buf, current_time, finish_time, python_timestep, vars) |
833 | |
834 | variable_loop: do j=1,size(vars) |
835 | ierr = adj_variable_get_timestep(vars(j), var_timestep) |
836 | @@ -522,5 +601,6 @@ |
837 | |
838 | deallocate(vars) |
839 | end subroutine adj_record_anything_necessary |
840 | + |
841 | #endif |
842 | end module adjoint_functional_evaluation |
843 | |
844 | === modified file 'adjoint/Adjoint_Global_Variables.F90' |
845 | --- adjoint/Adjoint_Global_Variables.F90 2011-04-01 17:40:34 +0000 |
846 | +++ adjoint/Adjoint_Global_Variables.F90 2011-07-12 15:56:32 +0000 |
847 | @@ -35,6 +35,5 @@ |
848 | |
849 | type(adj_dictionary) :: adj_path_lookup, adj_solver_path_lookup |
850 | type(adj_adjointer) :: adjointer |
851 | - logical :: functional_computed = .false. |
852 | #endif |
853 | end module adjoint_global_variables |
854 | |
855 | === modified file 'adjoint/Adjoint_Main_Loop.F90' |
856 | --- adjoint/Adjoint_Main_Loop.F90 2011-05-11 17:15:33 +0000 |
857 | +++ adjoint/Adjoint_Main_Loop.F90 2011-07-12 15:56:32 +0000 |
858 | @@ -39,6 +39,7 @@ |
859 | use global_parameters, only: OPTION_PATH_LEN, running_adjoint |
860 | use adjoint_global_variables |
861 | use adjoint_functional_evaluation |
862 | + use adjoint_controls |
863 | use populate_state_module |
864 | use signal_vars |
865 | use mangle_options_tree |
866 | @@ -53,7 +54,6 @@ |
867 | implicit none |
868 | |
869 | private |
870 | - public :: adjoint_main_loop_register_diagnostic |
871 | #ifdef HAVE_ADJOINT |
872 | public :: compute_adjoint |
873 | #endif |
874 | @@ -61,9 +61,28 @@ |
875 | contains |
876 | |
877 | #ifdef HAVE_ADJOINT |
878 | - subroutine compute_adjoint(state, dump_no) |
879 | + ! Computes the adjoint equation |
880 | + ! The optional adjoint timestep callback is called for each functional after every timestep in the adjoint loop. |
881 | + ! It is commonly used to compute the diangostics from the adjoint solution, e.g. the total derivative of the functional. |
882 | + subroutine compute_adjoint(state, dump_no, adjoint_timestep_callback, adjoint_timestep_callback_data) |
883 | + use iso_c_binding, only: c_ptr |
884 | type(state_type), dimension(:), intent(inout) :: state |
885 | integer, intent(inout) :: dump_no |
886 | + optional :: adjoint_timestep_callback |
887 | + ! Data is a void pointer used to pass variables into the callback |
888 | + type(c_ptr), intent(in), optional :: adjoint_timestep_callback_data |
889 | + interface |
890 | + subroutine adjoint_timestep_callback(state, timestep, functional_name, data) |
891 | + use iso_c_binding, only: c_ptr |
892 | + use global_parameters, only: OPTION_PATH_LEN |
893 | + use state_module |
894 | + type(state_type), dimension(:), intent(inout) :: state |
895 | + integer, intent(in) :: timestep |
896 | + character(len=OPTION_PATH_LEN), intent(in) :: functional_name |
897 | + ! Data is a void pointer used to pass variables into the callback |
898 | + type(c_ptr), intent(in) :: data |
899 | + end subroutine adjoint_timestep_callback |
900 | + end interface |
901 | |
902 | type(adj_vector) :: rhs |
903 | type(adj_vector) :: soln |
904 | @@ -80,10 +99,12 @@ |
905 | integer :: end_timestep, start_timestep, no_timesteps, timestep |
906 | real :: start_time, end_time |
907 | |
908 | - character(len=OPTION_PATH_LEN) :: simulation_base_name, functional_name |
909 | + character(len=OPTION_PATH_LEN) :: simulation_base_name |
910 | type(stat_type), dimension(:), allocatable :: functional_stats |
911 | + real :: J |
912 | + real, dimension(:), pointer :: fn_value |
913 | |
914 | - character(len=ADJ_NAME_LEN) :: variable_name, field_name, material_phase_name |
915 | + character(len=ADJ_NAME_LEN) :: variable_name, field_name, material_phase_name, functional_name |
916 | type(scalar_field) :: sfield_soln, sfield_rhs |
917 | type(vector_field) :: vfield_soln, vfield_rhs |
918 | type(csr_matrix) :: csr_mat |
919 | @@ -112,17 +133,29 @@ |
920 | allocate(functional_stats(no_functionals)) |
921 | |
922 | do functional=0,no_functionals-1 |
923 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
924 | + if (have_option("/adjoint/functional::" // trim(functional_name) // "/disable_adjoint_run")) then |
925 | + cycle |
926 | + end if |
927 | default_stat = functional_stats(functional + 1) |
928 | call initialise_walltime |
929 | - call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
930 | call initialise_diagnostics(trim(simulation_base_name) // '_' // trim(functional_name), state) |
931 | functional_stats(functional + 1) = default_stat |
932 | - |
933 | + |
934 | + ! Register the callback to compute J |
935 | + ierr = adj_register_functional_callback(adjointer, trim(functional_name), c_funloc(libadjoint_evaluate_functional)) |
936 | + call adj_chkierr(ierr) |
937 | + |
938 | ! Register the callback to compute delJ/delu |
939 | ierr = adj_register_functional_derivative_callback(adjointer, trim(functional_name), c_funloc(libadjoint_functional_derivative)) |
940 | call adj_chkierr(ierr) |
941 | end do |
942 | |
943 | + ! Insert the fields for storing the derivatives of the functionals with respect to the controls into the state |
944 | + if (have_option("/adjoint/controls")) then |
945 | + call allocate_and_insert_control_derivative_fields(state) |
946 | + end if |
947 | + |
948 | ierr = adj_timestep_count(adjointer, no_timesteps) |
949 | call adj_chkierr(ierr) |
950 | |
951 | @@ -145,18 +178,6 @@ |
952 | call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
953 | call set_option("/simulation_name", trim(simulation_base_name) // "_" // trim(functional_name)) |
954 | default_stat = functional_stats(functional + 1) |
955 | - ! We don't want to compute a functional for the dummy timestep added at the end to act |
956 | - ! as a container for the last equation |
957 | - if (start_time == end_time) then |
958 | - assert(timestep == no_timesteps-1) |
959 | - if (have_option("/adjoint/functional[" // int2str(functional) // "]/functional_value")) then |
960 | - call set_diagnostic(name=trim(functional_name), statistic="value", value=(/0.0/)) |
961 | - call set_diagnostic(name=trim(functional_name) // "_component", statistic="value", value=(/0.0/)) |
962 | - end if |
963 | - functional_computed = .true. |
964 | - else |
965 | - functional_computed = .false. |
966 | - end if |
967 | |
968 | do equation=end_timestep,start_timestep,-1 |
969 | ierr = adj_get_adjoint_equation(adjointer, equation, trim(functional_name), lhs, rhs, adj_var) |
970 | @@ -201,7 +222,7 @@ |
971 | end if |
972 | |
973 | call petsc_solve(sfield_soln, csr_mat, sfield_rhs, option_path=path) |
974 | - !call compute_inactive_rows(sfield_soln, csr_mat, sfield_rhs) |
975 | + call compute_inactive_rows(sfield_soln, csr_mat, sfield_rhs) |
976 | endif |
977 | case(ADJ_BLOCK_CSR_MATRIX) |
978 | FLAbort("Cannot map between scalar fields with a block_csr_matrix .. ") |
979 | @@ -240,7 +261,7 @@ |
980 | end if |
981 | |
982 | call petsc_solve(vfield_soln, csr_mat, vfield_rhs, option_path=path) |
983 | - call compute_inactive_rows(vfield_soln, csr_mat, vfield_rhs) |
984 | + !call compute_inactive_rows(vfield_soln, csr_mat, vfield_rhs) |
985 | endif |
986 | case(ADJ_BLOCK_CSR_MATRIX) |
987 | call matrix_from_adj_matrix(lhs, block_csr_mat) |
988 | @@ -282,7 +303,16 @@ |
989 | call adjoint_cleanup |
990 | return |
991 | end if |
992 | - end do |
993 | + end do ! End of equation loop |
994 | + |
995 | + ! Callback for the computation of the functional total derivatives |
996 | + if (present(adjoint_timestep_callback)) then |
997 | + call adjoint_timestep_callback(state, timestep, trim(functional_name), data=adjoint_timestep_callback_data) |
998 | + end if |
999 | + if (have_option("/adjoint/controls")) then |
1000 | + ! Write the functional's total derivatives to file |
1001 | + call adjoint_write_control_derivatives(state, timestep, trim(functional_name)) |
1002 | + end if |
1003 | |
1004 | call calculate_diagnostic_variables(state, exclude_nonrecalculated = .true.) |
1005 | call calculate_diagnostic_variables_new(state, exclude_nonrecalculated = .true.) |
1006 | @@ -296,13 +326,13 @@ |
1007 | endif |
1008 | |
1009 | functional_stats(functional + 1) = default_stat |
1010 | - end do |
1011 | + end do ! End of functional loop |
1012 | |
1013 | ! Now forget |
1014 | ierr = adj_forget_adjoint_equation(adjointer, start_timestep) |
1015 | call adj_chkierr(ierr) |
1016 | current_time = start_time |
1017 | - end do |
1018 | + end do ! End of timestep loop |
1019 | |
1020 | call get_option("/timestepping/finish_time", finish_time) |
1021 | assert(current_time == finish_time) |
1022 | @@ -314,6 +344,10 @@ |
1023 | subroutine adjoint_cleanup |
1024 | ! Clean up stat files |
1025 | do functional=0,no_functionals-1 |
1026 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
1027 | + if (have_option("/adjoint/functional::" // trim(functional_name) // "/disable_adjoint_run")) then |
1028 | + cycle |
1029 | + end if |
1030 | default_stat = functional_stats(functional + 1) |
1031 | call close_diagnostic_files |
1032 | call uninitialise_diagnostics |
1033 | @@ -325,23 +359,7 @@ |
1034 | call adj_chkierr(ierr) |
1035 | end subroutine adjoint_cleanup |
1036 | end subroutine compute_adjoint |
1037 | + |
1038 | #endif |
1039 | |
1040 | - subroutine adjoint_main_loop_register_diagnostic |
1041 | - integer :: functional, no_functionals |
1042 | - character(len=OPTION_PATH_LEN) :: functional_name |
1043 | - |
1044 | - no_functionals = option_count("/adjoint/functional") |
1045 | - |
1046 | - do functional=0,no_functionals-1 |
1047 | - ! Register a diagnostic for each functional |
1048 | - if (have_option("/adjoint/functional[" // int2str(functional) // "]/functional_value")) then |
1049 | - call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
1050 | - call register_diagnostic(dim=1, name=trim(functional_name) // "_component", statistic="value") |
1051 | - call register_diagnostic(dim=1, name=trim(functional_name), statistic="value") |
1052 | - end if |
1053 | - end do |
1054 | - |
1055 | - end subroutine adjoint_main_loop_register_diagnostic |
1056 | - |
1057 | end module adjoint_main_loop |
1058 | |
1059 | === modified file 'adjoint/Adjoint_Python_Fortran.F90' |
1060 | --- adjoint/Adjoint_Python_Fortran.F90 2011-05-01 19:08:55 +0000 |
1061 | +++ adjoint/Adjoint_Python_Fortran.F90 2011-07-12 15:56:32 +0000 |
1062 | @@ -40,9 +40,11 @@ |
1063 | public :: adj_variables_from_python |
1064 | |
1065 | interface |
1066 | - subroutine adj_variables_from_python_c(fn, fnlen, start_time, end_time, timestep, result, result_len, stat) & |
1067 | + subroutine adj_variables_from_python_c(adjointer, fn, fnlen, start_time, end_time, timestep, result, result_len, stat) & |
1068 | & bind(c, name='adj_variables_from_python') |
1069 | + use libadjoint |
1070 | use iso_c_binding |
1071 | + type(adj_adjointer), intent(in) :: adjointer |
1072 | integer(kind=c_int), intent(in), value :: fnlen |
1073 | character(kind=c_char), dimension(fnlen), intent(in) :: fn |
1074 | real(kind=c_double), intent(in), value :: start_time, end_time |
1075 | @@ -60,7 +62,8 @@ |
1076 | |
1077 | contains |
1078 | |
1079 | - subroutine adj_variables_from_python(fn, start_time, end_time, timestep, result, extras, stat) |
1080 | + subroutine adj_variables_from_python(adjointer, fn, start_time, end_time, timestep, result, extras, stat) |
1081 | + type(adj_adjointer), intent(in) :: adjointer |
1082 | character(len=*), intent(in) :: fn |
1083 | real, intent(in) :: start_time, end_time |
1084 | integer, intent(in) :: timestep |
1085 | @@ -88,7 +91,7 @@ |
1086 | |
1087 | timestep_long = timestep |
1088 | |
1089 | - call adj_variables_from_python_c(fn_c, len_trim(fn), start_time, end_time, timestep_long, result_c_ptr, result_len_c, stat_c) |
1090 | + call adj_variables_from_python_c(adjointer, fn_c, len_trim(fn), start_time, end_time, timestep_long, result_c_ptr, result_len_c, stat_c) |
1091 | |
1092 | if (stat_c /= 0) then |
1093 | if (present(stat)) then |
1094 | |
1095 | === modified file 'adjoint/Burgers_Adjoint_Callbacks.F90' |
1096 | --- adjoint/Burgers_Adjoint_Callbacks.F90 2011-04-01 17:40:34 +0000 |
1097 | +++ adjoint/Burgers_Adjoint_Callbacks.F90 2011-07-12 15:56:32 +0000 |
1098 | @@ -40,6 +40,9 @@ |
1099 | use adjoint_global_variables, only: adj_path_lookup |
1100 | use mangle_options_tree, only: adjoint_field_path |
1101 | use mangle_dirichlet_rows_module |
1102 | + use populate_state_module |
1103 | + use burgers_assembly |
1104 | + use global_parameters, only: OPTION_PATH_LEN, running_adjoint |
1105 | implicit none |
1106 | |
1107 | private |
1108 | @@ -61,6 +64,15 @@ |
1109 | call adj_chkierr(ierr) |
1110 | ierr = adj_register_operator_callback(adjointer, ADJ_BLOCK_ACTION_CB, "TimesteppingOperator", c_funloc(timestepping_operator_action_callback)) |
1111 | call adj_chkierr(ierr) |
1112 | + |
1113 | + ierr = adj_register_operator_callback(adjointer, ADJ_NBLOCK_DERIVATIVE_ACTION_CB, "AdvectionOperator", c_funloc(advection_derivative_action_proc)) |
1114 | + call adj_chkierr(ierr) |
1115 | + |
1116 | + ierr = adj_register_operator_callback(adjointer, ADJ_NBLOCK_ACTION_CB, "AdvectionOperator", c_funloc(advection_action_proc)) |
1117 | + call adj_chkierr(ierr) |
1118 | + |
1119 | + ierr = adj_register_forward_source_callback(adjointer, c_funloc(burgers_equation_forward_source)) |
1120 | + call adj_chkierr(ierr) |
1121 | end subroutine register_burgers_operator_callbacks |
1122 | |
1123 | subroutine velocity_identity_assembly_callback(nvar, variables, dependencies, hermitian, coefficient, context, output, rhs) bind(c) |
1124 | @@ -114,9 +126,11 @@ |
1125 | type(scalar_field) :: empty_velocity_field, previous_u, iter_u |
1126 | type(scalar_field), dimension(2) :: deps |
1127 | type(csr_matrix), pointer :: mass_mat, diffusion_mat |
1128 | - type(csr_matrix) :: burgers_mat, burgers_mat_T |
1129 | + type(csr_matrix) :: burgers_mat, burgers_mat_T, advection_mat |
1130 | + type(vector_field), pointer :: positions |
1131 | real :: dt, theta |
1132 | integer :: i |
1133 | + character(len=FIELD_NAME_LEN) :: path |
1134 | |
1135 | if (coefficient /= 1.0) then |
1136 | FLAbort("The coefficient in burgers_operator_assembly_callback has to be 1.0") |
1137 | @@ -139,13 +153,20 @@ |
1138 | FLAbort("Unknown number of dependencies in burgers_operator_assembly_callback") |
1139 | end if |
1140 | |
1141 | - call get_option(trim(adjoint_field_path("/material_phase::Fluid/scalar_field::Velocity/prognostic/temporal_discretisation/theta")), theta) |
1142 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1143 | + if (running_adjoint) then |
1144 | + path = adjoint_field_path("/material_phase::Fluid/scalar_field::Velocity") |
1145 | + end if |
1146 | + |
1147 | + call get_option(trim(path) // "/prognostic/temporal_discretisation/theta", theta, default=0.5) |
1148 | call get_option("/timestepping/timestep", dt) |
1149 | + dt = abs(dt) |
1150 | |
1151 | call c_f_pointer(context, matrices) |
1152 | u_mesh => extract_mesh(matrices, "VelocityMesh") |
1153 | diffusion_mat => extract_csr_matrix(matrices, "DiffusionMatrix") |
1154 | mass_mat => extract_csr_matrix(matrices, "MassMatrix") |
1155 | + positions => extract_vector_field(matrices, "Coordinate") |
1156 | |
1157 | call allocate(empty_velocity_field, u_mesh, trim("AdjointPressureRhs")) |
1158 | call zero(empty_velocity_field) |
1159 | @@ -156,10 +177,18 @@ |
1160 | call allocate(burgers_mat, mass_mat%sparsity, name="BurgersAdjointOutput") |
1161 | call zero(burgers_mat) |
1162 | |
1163 | - if (.not. have_option(trim(adjoint_field_path('/material_phase::Fluid/scalar_field::Velocity/prognostic/temporal_discretisation/remove_time_term')))) then |
1164 | + if (.not. have_option(trim(path) // '/prognostic/temporal_discretisation/remove_time_term')) then |
1165 | call addto(burgers_mat, mass_mat, 1.0/abs(dt)) |
1166 | end if |
1167 | - !call addto(burgers_mat, advection_mat, theta) |
1168 | + |
1169 | + if (.not. have_option(trim(path) // '/prognostic/remove_advection_term')) then |
1170 | + call allocate(advection_mat, mass_mat%sparsity, name="BurgersCallbackAdvectionMatrix") |
1171 | + call zero(advection_mat) |
1172 | + call assemble_advection_matrix(advection_mat, positions, previous_u, iter_u) |
1173 | + call addto(burgers_mat, advection_mat, theta) |
1174 | + call deallocate(advection_mat) |
1175 | + end if |
1176 | + |
1177 | call addto(burgers_mat, diffusion_mat, theta) |
1178 | |
1179 | ! Ensure that the input velocity has indeed dirichlet bc attached |
1180 | @@ -223,12 +252,15 @@ |
1181 | |
1182 | type(state_type), pointer :: matrices |
1183 | type(csr_matrix), pointer :: diffusion_mat, mass_mat |
1184 | - type(csr_matrix) :: timestepping_mat |
1185 | type(mesh_type), pointer :: u_mesh |
1186 | ! Input/output variables |
1187 | type(scalar_field) :: u_input, previous_u, iter_u |
1188 | - type(scalar_field) :: u_output |
1189 | + type(scalar_field) :: u_output, tmp_u |
1190 | real :: theta, dt |
1191 | + character(len=FIELD_NAME_LEN) :: path |
1192 | + type(csr_matrix) :: advection_mat |
1193 | + type(vector_field), pointer :: positions |
1194 | + type(csr_matrix) :: timestepping_mat |
1195 | |
1196 | call c_f_pointer(context, matrices) |
1197 | |
1198 | @@ -240,6 +272,7 @@ |
1199 | u_mesh => extract_mesh(matrices, "VelocityMesh") |
1200 | diffusion_mat => extract_csr_matrix(matrices, "DiffusionMatrix") |
1201 | mass_mat => extract_csr_matrix(matrices, "MassMatrix") |
1202 | + positions => extract_vector_field(matrices, "Coordinate") |
1203 | |
1204 | if (nvar==2) then |
1205 | if (variables(1)%timestep==variables(2)%timestep-1) then |
1206 | @@ -259,29 +292,45 @@ |
1207 | end if |
1208 | |
1209 | ! Ensure that the input velocity has indeed dirichlet bc attached |
1210 | - ! Ensure that the input velocity has indeed dirichlet bc attached |
1211 | if (get_boundary_condition_count(previous_u)==0) then |
1212 | FLAbort("Velocity in callback must have dirichlet conditions attached") |
1213 | end if |
1214 | |
1215 | call field_from_adj_vector(input, u_input) |
1216 | - |
1217 | + |
1218 | call allocate(u_output, u_mesh, "TimeSteppingAdjointVelocityOutput") |
1219 | call zero(u_output) |
1220 | + call allocate(tmp_u, u_mesh, "TimeSteppingAdjointVelocityOutput") |
1221 | + call zero(tmp_u) |
1222 | |
1223 | call allocate(timestepping_mat, mass_mat%sparsity, name="TimesteppingMatrix") |
1224 | call zero(timestepping_mat) |
1225 | |
1226 | - if (.not. have_option(trim(adjoint_field_path('/material_phase::Fluid/scalar_field::Velocity/prognostic/temporal_discretisation/remove_time_term')))) then |
1227 | - call addto(timestepping_mat, mass_mat, scale=1.0/dt) |
1228 | - end if |
1229 | - |
1230 | -! call mult(tmp, advection_mat, u_input) |
1231 | -! call scale(tmp, theta - 1.0) |
1232 | -! call addto(u_output, tmp) |
1233 | - |
1234 | - call addto(timestepping_mat, diffusion_mat, scale=theta - 1.0) |
1235 | - |
1236 | + if (running_adjoint) then |
1237 | + path = adjoint_field_path("/material_phase::Fluid/scalar_field::Velocity") |
1238 | + else |
1239 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1240 | + end if |
1241 | + |
1242 | + if (.not. have_option(trim(path) // '/prognostic/temporal_discretisation/remove_time_term')) then |
1243 | + call addto(timestepping_mat, mass_mat, scale=1.0/abs(dt)) |
1244 | + end if |
1245 | + |
1246 | + if (.not. have_option(trim(path) // '/prognostic/remove_advection_term')) then |
1247 | + call allocate(advection_mat, mass_mat%sparsity, name="BurgersCallbackAdvectionMatrix") |
1248 | + call zero(advection_mat) |
1249 | + call assemble_advection_matrix(advection_mat, positions, previous_u, iter_u) |
1250 | + call addto(timestepping_mat, advection_mat, scale=theta-1.0) |
1251 | + call deallocate(advection_mat) |
1252 | + end if |
1253 | + |
1254 | + call addto(timestepping_mat, diffusion_mat, scale=theta-1.0) |
1255 | + |
1256 | + call scale(timestepping_mat, -1.0) |
1257 | + if (get_boundary_condition_count(previous_u)==0) then |
1258 | + FLAbort("Velocity in callback must have dirichlet conditions attached") |
1259 | + end if |
1260 | + ! Mangle the dirichlet rows |
1261 | call mangle_dirichlet_rows(timestepping_mat, previous_u, keep_diag=.false.) |
1262 | |
1263 | if (hermitian==ADJ_FALSE) then |
1264 | @@ -289,12 +338,283 @@ |
1265 | else |
1266 | call mult_T(u_output, timestepping_mat, u_input) |
1267 | end if |
1268 | + |
1269 | + call deallocate(timestepping_mat) |
1270 | + |
1271 | call scale(u_output, coefficient) |
1272 | output = field_to_adj_vector(u_output) |
1273 | call deallocate(u_output) |
1274 | - call deallocate(timestepping_mat) |
1275 | + call deallocate(tmp_u) |
1276 | end subroutine timestepping_operator_action_callback |
1277 | |
1278 | - |
1279 | + subroutine advection_derivative_action_proc(nvar, variables, dependencies, derivative, contraction, hermitian, & |
1280 | + & input, coefficient, context, output) bind(c) |
1281 | + use iso_c_binding |
1282 | + use libadjoint_data_structures |
1283 | + use simple_advection_d |
1284 | + use simple_advection_b |
1285 | + integer(kind=c_int), intent(in), value :: nvar |
1286 | + type(adj_variable), dimension(nvar), intent(in) :: variables |
1287 | + type(adj_vector), dimension(nvar), intent(in) :: dependencies |
1288 | + type(adj_variable), intent(in), value :: derivative |
1289 | + type(adj_vector), intent(in), value :: contraction |
1290 | + integer(kind=c_int), intent(in), value :: hermitian |
1291 | + type(adj_vector), intent(in), value :: input |
1292 | + adj_scalar_f, intent(in), value :: coefficient |
1293 | + type(c_ptr), intent(in), value :: context |
1294 | + type(adj_vector), intent(out) :: output |
1295 | + |
1296 | + type(state_type), pointer :: matrices |
1297 | + type(vector_field), pointer :: positions |
1298 | + type(scalar_field) :: u_left, u_right |
1299 | + type(scalar_field) :: contraction_field, udot, Acbar |
1300 | + type(scalar_field) :: output_field, tmp_field, u |
1301 | + character(len=OPTION_PATH_LEN) :: path |
1302 | + |
1303 | + real :: itheta |
1304 | + |
1305 | + assert(nvar == 1 .or. nvar == 2) |
1306 | + call c_f_pointer(context, matrices) |
1307 | + positions => extract_vector_field(matrices, "Coordinate") |
1308 | + |
1309 | + call field_from_adj_vector(contraction, contraction_field) |
1310 | + call allocate(output_field, contraction_field%mesh, "NonlinearDerivativeOutput") |
1311 | + call zero(output_field) |
1312 | + |
1313 | + if (have_option("/material_phase::Fluid/scalar_field::Velocity")) then |
1314 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1315 | + else |
1316 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1317 | + path = adjoint_field_path(path) |
1318 | + end if |
1319 | + |
1320 | + if (hermitian == ADJ_FALSE) then |
1321 | + call field_from_adj_vector(input, udot) |
1322 | + call get_option(trim(path) // "/prognostic/temporal_discretisation/relaxation", itheta) |
1323 | + if (have_option(trim(path) // "/prognostic/remove_advection_term")) then |
1324 | + output = field_to_adj_vector(output_field) |
1325 | + call deallocate(output_field) |
1326 | + return |
1327 | + end if |
1328 | + else |
1329 | + call get_option(trim(path) // "/prognostic/temporal_discretisation/relaxation", itheta) |
1330 | + call field_from_adj_vector(input, Acbar) |
1331 | + if (have_option(trim(path) // "/prognostic/remove_advection_term")) then |
1332 | + output = field_to_adj_vector(output_field) |
1333 | + call deallocate(output_field) |
1334 | + return |
1335 | + end if |
1336 | + end if |
1337 | + |
1338 | + call allocate(tmp_field, contraction_field%mesh, "TmpOutput") |
1339 | + call zero(tmp_field) |
1340 | + |
1341 | + if (nvar == 1) then |
1342 | + call field_from_adj_vector(dependencies(1), u_left) |
1343 | + if (hermitian == ADJ_FALSE) then |
1344 | + call advection_action_d(positions%val(1,:), u_left%val, udot%val, contraction_field%val, tmp_field%val, output_field%val) |
1345 | + else |
1346 | + call advection_action_b(positions%val(1,:), u_left%val, output_field%val, contraction_field%val, tmp_field%val, Acbar%val) |
1347 | + end if |
1348 | + else if (nvar == 2) then |
1349 | + call field_from_adj_vector(dependencies(1), u_left) |
1350 | + call field_from_adj_vector(dependencies(2), u_right) |
1351 | + call allocate(u, u_left%mesh, "AdvectingVelocity") |
1352 | + call set(u, u_left) |
1353 | + call scale(u, (1.0-itheta)) |
1354 | + call addto(u, u_right, scale=itheta) |
1355 | + |
1356 | + if (hermitian == ADJ_FALSE) then |
1357 | + call advection_action_d(positions%val(1,:), u%val, udot%val, contraction_field%val, tmp_field%val, output_field%val) |
1358 | + else |
1359 | + call advection_action_b(positions%val(1,:), u%val, output_field%val, contraction_field%val, tmp_field%val, Acbar%val) |
1360 | + end if |
1361 | + |
1362 | + call deallocate(u) |
1363 | + |
1364 | + if (derivative == variables(1)) then |
1365 | + call scale(output_field, (1.0-itheta)) |
1366 | + else if (derivative == variables(2)) then |
1367 | + call scale(output_field, itheta) |
1368 | + end if |
1369 | + end if |
1370 | + |
1371 | + call deallocate(tmp_field) |
1372 | + call scale(output_field, coefficient) |
1373 | + output = field_to_adj_vector(output_field) |
1374 | + call deallocate(output_field) |
1375 | + end subroutine advection_derivative_action_proc |
1376 | + |
1377 | + subroutine burgers_equation_forward_source(adjointer, var, ndepends, dependencies, values, context, output, has_output) bind(c) |
1378 | + type(adj_adjointer), intent(in) :: adjointer |
1379 | + type(adj_variable), intent(in), value :: var |
1380 | + integer(kind=c_int), intent(in), value :: ndepends |
1381 | + type(adj_variable), dimension(ndepends), intent(in) :: dependencies |
1382 | + type(adj_vector), dimension(ndepends), intent(in) :: values |
1383 | + type(c_ptr), intent(in), value :: context |
1384 | + type(adj_vector), intent(out) :: output |
1385 | + integer(kind=c_int), intent(out) :: has_output |
1386 | + |
1387 | + character(len=ADJ_DICT_LEN) :: path |
1388 | + character(len=ADJ_NAME_LEN) :: name |
1389 | + integer :: timestep |
1390 | + real :: time, dt, end_time |
1391 | + real :: theta |
1392 | + type(state_type), pointer :: matrices |
1393 | + logical :: has_source |
1394 | + type(mesh_type), pointer :: u_mesh |
1395 | + type(state_type), dimension(1) :: dummy_state |
1396 | + type(scalar_field) :: u_output, tmp_u_output, dummy_u |
1397 | + type(csr_matrix), pointer :: mass_matrix |
1398 | + type(vector_field), pointer :: positions |
1399 | + type(csr_matrix) :: mangled_mass_matrix |
1400 | + |
1401 | + integer :: ierr |
1402 | + |
1403 | + ierr = adj_variable_get_name(var, name) |
1404 | + call adj_chkierr(ierr) |
1405 | + |
1406 | + ierr = adj_variable_get_timestep(var, timestep) |
1407 | + call adj_chkierr(ierr) |
1408 | + |
1409 | + call c_f_pointer(context, matrices) |
1410 | + assert(associated(matrices)) |
1411 | + u_mesh => extract_mesh(matrices, "VelocityMesh") |
1412 | + positions => extract_vector_field(matrices, "Coordinate") |
1413 | + mass_matrix => extract_csr_matrix(matrices, "MassMatrix") |
1414 | + |
1415 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1416 | + |
1417 | + has_source = have_option(trim(path) // "/prognostic/scalar_field::Source") |
1418 | + |
1419 | + if (timestep == 0) then ! initial condition |
1420 | + call allocate(u_output, u_mesh, "VelocityInitialCondition") |
1421 | + call zero(u_output) |
1422 | + u_output%option_path = trim(path) |
1423 | + call insert(dummy_state(1), positions, "Coordinate") |
1424 | + call insert(dummy_state(1), u_output, "Velocity") |
1425 | + call initialise_prognostic_fields(dummy_state) |
1426 | + |
1427 | + ! Set initial condition |
1428 | + call populate_boundary_conditions(dummy_state) |
1429 | + call set_boundary_conditions_values(dummy_state, shift_time=.false.) |
1430 | + call set_dirichlet_consistent(dummy_state) |
1431 | + call deallocate(dummy_state(1)) |
1432 | + |
1433 | + output = field_to_adj_vector(u_output) |
1434 | + has_output = ADJ_TRUE |
1435 | + call deallocate(u_output) |
1436 | + else if (timestep > 0) then |
1437 | + if (.not. has_source) then |
1438 | + has_output = ADJ_FALSE |
1439 | + else |
1440 | + call allocate(tmp_u_output, u_mesh, "VelocitySource") |
1441 | + call allocate(u_output, u_mesh, "VelocitySource") |
1442 | + call allocate(dummy_u, u_mesh, "DummyVelocity") |
1443 | + call zero(tmp_u_output) |
1444 | + call zero(u_output) |
1445 | + tmp_u_output%option_path = trim(path) // "/prognostic/scalar_field::Source" |
1446 | + dummy_u%option_path = trim(path) |
1447 | + |
1448 | + call insert(dummy_state(1), positions, "Coordinate") |
1449 | + call insert(dummy_state(1), tmp_u_output, "VelocitySource") |
1450 | + call insert(dummy_state(1), dummy_u, "DummyVelocity") |
1451 | + |
1452 | + call populate_boundary_conditions(dummy_state) |
1453 | + |
1454 | + ierr = adj_timestep_get_times(adjointer, timestep-1, time, end_time) |
1455 | + call adj_chkierr(ierr) |
1456 | + dt = end_time - time |
1457 | + |
1458 | + call get_option(trim(path) // "/prognostic/temporal_discretisation/theta", theta, default=0.5) |
1459 | + call set_prescribed_field_values(dummy_state, time=time + theta*abs(dt)) |
1460 | + call deallocate(dummy_state(1)) |
1461 | + |
1462 | + call allocate(mangled_mass_matrix, mass_matrix%sparsity, name="MangledMassMatrix") |
1463 | + call set(mangled_mass_matrix, mass_matrix) |
1464 | + call mangle_dirichlet_rows(mangled_mass_matrix, dummy_u, keep_diag=.false.) |
1465 | + call mult(u_output, mangled_mass_matrix, tmp_u_output) |
1466 | + call deallocate(mangled_mass_matrix) |
1467 | + |
1468 | + call deallocate(tmp_u_output) |
1469 | + call deallocate(dummy_u) |
1470 | + |
1471 | + output = field_to_adj_vector(u_output) |
1472 | + has_output = ADJ_TRUE |
1473 | + call deallocate(u_output) |
1474 | + end if |
1475 | + end if |
1476 | + |
1477 | + end subroutine burgers_equation_forward_source |
1478 | + |
1479 | + subroutine advection_action_proc(nvar, variables, dependencies, input, context, output) bind(c) |
1480 | + use iso_c_binding |
1481 | + use libadjoint_data_structures |
1482 | + use simple_advection |
1483 | + integer(kind=c_int), intent(in), value :: nvar |
1484 | + type(adj_variable), dimension(nvar), intent(in) :: variables |
1485 | + type(adj_vector), dimension(nvar), intent(in) :: dependencies |
1486 | + type(adj_vector), intent(in), value :: input |
1487 | + type(c_ptr), intent(in), value :: context |
1488 | + type(adj_vector), intent(out) :: output |
1489 | + |
1490 | + type(scalar_field) :: u_output, u_check, nonlinear_u |
1491 | + type(scalar_field) :: previous_u, iter_u, u_input |
1492 | + type(csr_matrix) :: advection_mat |
1493 | + type(csr_matrix), pointer :: diffusion_mat |
1494 | + type(vector_field), pointer :: positions |
1495 | + type(mesh_type), pointer :: u_mesh |
1496 | + type(state_type), pointer :: matrices |
1497 | + character(len=OPTION_PATH_LEN) :: path |
1498 | + real :: itheta |
1499 | + |
1500 | + path = "/material_phase::Fluid/scalar_field::Velocity" |
1501 | + if (running_adjoint) then |
1502 | + path = adjoint_field_path(path) |
1503 | + end if |
1504 | + |
1505 | + if (nvar==2) then |
1506 | + if (variables(1)%timestep==variables(2)%timestep-1) then |
1507 | + call field_from_adj_vector(dependencies(1), previous_u) |
1508 | + call field_from_adj_vector(dependencies(2), iter_u) |
1509 | + else if(variables(2)%timestep==variables(1)%timestep-1) then |
1510 | + call field_from_adj_vector(dependencies(2), previous_u) |
1511 | + call field_from_adj_vector(dependencies(1), iter_u) |
1512 | + else |
1513 | + FLAbort("Dependencies have no contiguous timesteps.") |
1514 | + end if |
1515 | + else if (nvar==1) then |
1516 | + call field_from_adj_vector(dependencies(1), previous_u) |
1517 | + call field_from_adj_vector(dependencies(1), iter_u) |
1518 | + else |
1519 | + FLAbort("Unknown number of dependencies in burgers_operator_assembly_callback") |
1520 | + end if |
1521 | + |
1522 | + call field_from_adj_vector(input, u_input) |
1523 | + |
1524 | + call c_f_pointer(context, matrices) |
1525 | + u_mesh => extract_mesh(matrices, "VelocityMesh") |
1526 | + diffusion_mat => extract_csr_matrix(matrices, "DiffusionMatrix") |
1527 | + positions => extract_vector_field(matrices, "Coordinate") |
1528 | + |
1529 | + call allocate(advection_mat, diffusion_mat%sparsity, name="AdvectionActionMatrix") |
1530 | + call zero(advection_mat) |
1531 | + if (.not. have_option(trim(path) // "/prognostic/remove_advection_term")) then |
1532 | + call assemble_advection_matrix(advection_mat, positions, previous_u, iter_u) |
1533 | + end if |
1534 | + |
1535 | + if (get_boundary_condition_count(previous_u) /= 1) then |
1536 | + FLAbort("Need to supply boundary conditions on previous_u") |
1537 | + end if |
1538 | + |
1539 | + call mangle_dirichlet_rows(advection_mat, previous_u, keep_diag=.true.) |
1540 | + |
1541 | + call allocate(u_output, u_mesh, "AdvectionActionOutput") |
1542 | + call mult(u_output, advection_mat, u_input) |
1543 | + call deallocate(advection_mat) |
1544 | + |
1545 | + output = field_to_adj_vector(u_output) |
1546 | + call deallocate(u_output) |
1547 | + end subroutine advection_action_proc |
1548 | #endif |
1549 | end module burgers_adjoint_callbacks |
1550 | |
1551 | === added file 'adjoint/Burgers_Control_Callbacks.F90' |
1552 | --- adjoint/Burgers_Control_Callbacks.F90 1970-01-01 00:00:00 +0000 |
1553 | +++ adjoint/Burgers_Control_Callbacks.F90 2011-07-12 15:56:32 +0000 |
1554 | @@ -0,0 +1,183 @@ |
1555 | +! Copyright (C) 2006 Imperial College London and others. |
1556 | +! |
1557 | +! Please see the AUTHORS file in the main source directory for a full list |
1558 | +! of copyright holders. |
1559 | +! |
1560 | +! Prof. C Pain |
1561 | +! Applied Modelling and Computation Group |
1562 | +! Department of Earth Science and Engineering |
1563 | +! Imperial College London |
1564 | +! |
1565 | +! amcgsoftware@imperial.ac.uk |
1566 | +! |
1567 | +! This library is free software; you can redistribute it and/or |
1568 | +! modify it under the terms of the GNU Lesser General Public |
1569 | +! License as published by the Free Software Foundation, |
1570 | +! version 2.1 of the License. |
1571 | +! |
1572 | +! This library is distributed in the hope that it will be useful, |
1573 | +! but WITHOUT ANY WARRANTY; without even the implied warranty of |
1574 | +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
1575 | +! Lesser General Public License for more details. |
1576 | +! |
1577 | +! You should have received a copy of the GNU Lesser General Public |
1578 | +! License along with this library; if not, write to the Free Software |
1579 | +! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
1580 | +! USA |
1581 | + |
1582 | +#include "fdebug.h" |
1583 | + |
1584 | +module burgers_adjoint_controls |
1585 | + use fields |
1586 | + use global_parameters, only : PYTHON_FUNC_LEN, OPTION_PATH_LEN |
1587 | + use spud |
1588 | + use state_module |
1589 | + use python_state |
1590 | + use sparse_matrices_fields |
1591 | + use manifold_projections |
1592 | + use mangle_dirichlet_rows_module |
1593 | + |
1594 | + implicit none |
1595 | + |
1596 | + private |
1597 | + |
1598 | + public :: burgers_adjoint_timestep_callback |
1599 | + |
1600 | + contains |
1601 | + |
1602 | + ! Data is a void pointer used to pass variables into the callback |
1603 | + subroutine burgers_adjoint_timestep_callback(states, timestep, functional_name, data) |
1604 | + use iso_c_binding, only: c_ptr |
1605 | + use global_parameters, only: OPTION_PATH_LEN |
1606 | + use state_module |
1607 | + type(state_type), dimension(:), intent(inout) :: states |
1608 | + integer, intent(in) :: timestep |
1609 | + character(len=*), intent(in) :: functional_name |
1610 | + type(c_ptr), intent(in) :: data |
1611 | + |
1612 | + type(state_type), pointer :: matrices |
1613 | + character(len=OPTION_PATH_LEN) :: field_name, control_type, control_deriv_name, field_deriv_name, name, material_phase_name |
1614 | + integer :: nb_controls |
1615 | + integer :: i, state_id, s_idx |
1616 | + type(scalar_field), pointer :: sfield, adj_sfield, adj_sfield2 |
1617 | + type(vector_field), pointer :: vfield, adj_vfield, positions |
1618 | + type(tensor_field), pointer :: tfield, adj_tfield |
1619 | + type(block_csr_matrix), pointer :: big_mat, div_mat, u_mass_mat |
1620 | + type(csr_matrix), pointer :: h_mass_mat |
1621 | + type(csr_matrix) :: h_mangled_mass_mat |
1622 | + type(state_type), dimension(1) :: dummy_state |
1623 | + |
1624 | + type(scalar_field) :: dummy_u |
1625 | + type(vector_field) :: local_src_tmp, local_src_tmp2, src_tmp |
1626 | + real :: theta, d0, dt |
1627 | + integer :: stat |
1628 | + |
1629 | + ! Cast the data to the matrices state |
1630 | + call c_f_pointer(data, matrices) |
1631 | + |
1632 | + |
1633 | + nb_controls = option_count("/adjoint/controls/control") |
1634 | + do i = 0, nb_controls-1 |
1635 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/name", control_deriv_name) |
1636 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type/name", control_type) |
1637 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type::" // trim(control_type) // "/field_name", name) |
1638 | + s_idx = scan(trim(name), "::") |
1639 | + if (s_idx == 0) then |
1640 | + FLAbort("The control " // trim(control_deriv_name) // " uses an invalid field_name. It should be of the form Materialphase::Fieldname") |
1641 | + end if |
1642 | + material_phase_name = name(1:s_idx - 1) |
1643 | + field_name = name(s_idx + 2:len_trim(name)) |
1644 | + ! Find state associated with the material phase |
1645 | + do state_id = 1, size(states) |
1646 | + if (trim(states(state_id)%name) == trim(material_phase_name)) then |
1647 | + exit |
1648 | + end if |
1649 | + end do |
1650 | + ! Make sure we found the state |
1651 | + if (.not. trim(states(state_id)%name) == trim(material_phase_name)) then |
1652 | + FLAbort("Could not find state " // trim(material_phase_name) // " as specified in control " // trim(control_deriv_name) // ".") |
1653 | + end if |
1654 | + |
1655 | + control_deriv_name = trim(control_deriv_name) // "_TotalDerivative" |
1656 | + select case(trim(control_type)) |
1657 | + |
1658 | + !!!!!!!!!!!!! Initial condition !!!!!!!!!!!! |
1659 | + case ("initial_condition") |
1660 | + if (timestep /= 0) then |
1661 | + cycle |
1662 | + end if |
1663 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
1664 | + if (has_scalar_field(states(state_id), field_deriv_name)) then |
1665 | + if (trim(field_name) == "Velocity") then |
1666 | + adj_sfield => extract_scalar_field(states(state_id), "Adjoint" // trim(field_name)) |
1667 | + sfield => extract_scalar_field(states(state_id), field_deriv_name) ! Output field |
1668 | + positions => extract_vector_field(matrices, "Coordinate") |
1669 | + call set(sfield, adj_sfield) |
1670 | + |
1671 | + ! Populate boundary conditions |
1672 | + call allocate(dummy_u, adj_sfield%mesh, "DummyVelocity") |
1673 | + dummy_u%option_path = "/material_phase::Fluid/scalar_field::AdjointVelocity" |
1674 | + call insert(dummy_state(1), positions, "Coordinate") |
1675 | + call insert(dummy_state(1), dummy_u, "AdjointVelocity") |
1676 | + call populate_boundary_conditions(dummy_state) |
1677 | + |
1678 | + ! Now we need to zero the derivative field everywhere we have Dirichlet conditions |
1679 | + call mangle_dirichlet_rows(sfield, dummy_u) |
1680 | + |
1681 | + call deallocate(dummy_u) |
1682 | + call deallocate(dummy_state(1)) |
1683 | + else |
1684 | + FLAbort("Sorry, I do not know how to compute the intial condition control for " // trim(field_name) // ".") |
1685 | + end if |
1686 | + else |
1687 | + FLAbort("The control derivative field " // trim(field_deriv_name) // " specified for " // trim(control_deriv_name) // " is not a field in the state.") |
1688 | + end if |
1689 | + |
1690 | + !!!!!!!!!!!!! Boundary condition !!!!!!!!!!!! |
1691 | + case("boundary_condition") |
1692 | + FLAbort("Boundary condition control not implemented yet.") |
1693 | + |
1694 | + !!!!!!!!!!!!! Source !!!!!!!!!!!! |
1695 | + case("source_term") |
1696 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
1697 | + sfield => extract_scalar_field(states(state_id), field_deriv_name, stat=stat) ! Output field |
1698 | + if (stat /= 0) then |
1699 | + FLAbort("The control derivative field " // trim(field_deriv_name) // " specified for " // trim(control_deriv_name) // " is not a field in the state.") |
1700 | + end if |
1701 | + |
1702 | + if (timestep == 0) then |
1703 | + call zero(sfield) |
1704 | + else |
1705 | + if (trim(field_name) == "VelocitySource") then |
1706 | + adj_sfield => extract_scalar_field(states(state_id), "AdjointVelocity") |
1707 | + h_mass_mat => extract_csr_matrix(matrices, "MassMatrix") |
1708 | + positions => extract_vector_field(matrices, "Coordinate") |
1709 | + |
1710 | + ! Populate boundary conditions |
1711 | + call allocate(dummy_u, adj_sfield%mesh, "DummyVelocity") |
1712 | + dummy_u%option_path = "/material_phase::Fluid/scalar_field::AdjointVelocity" |
1713 | + call insert(dummy_state(1), positions, "Coordinate") |
1714 | + call insert(dummy_state(1), dummy_u, "AdjointVelocity") |
1715 | + call populate_boundary_conditions(dummy_state) |
1716 | + |
1717 | + ! Mangle the mass matrix |
1718 | + call allocate(h_mangled_mass_mat, h_mass_mat%sparsity, name="MangledMassMatrix") |
1719 | + call set(h_mangled_mass_mat, h_mass_mat) |
1720 | + call mangle_dirichlet_rows(h_mangled_mass_mat, dummy_u, keep_diag=.false.) |
1721 | + call mult_T(sfield, h_mangled_mass_mat, adj_sfield) |
1722 | + |
1723 | + ! Deallocate temporary variables |
1724 | + call deallocate(dummy_state(1)) |
1725 | + call deallocate(dummy_u) |
1726 | + call deallocate(h_mangled_mass_mat) |
1727 | + |
1728 | + else |
1729 | + FLAbort("Sorry, I do not know how to compute the source condition control for " // trim(field_name) // ".") |
1730 | + end if |
1731 | + end if |
1732 | + end select |
1733 | + end do |
1734 | + |
1735 | + end subroutine burgers_adjoint_timestep_callback |
1736 | + |
1737 | +end module burgers_adjoint_controls |
1738 | |
1739 | === modified file 'adjoint/Forward_Main_Loop.F90' |
1740 | --- adjoint/Forward_Main_Loop.F90 2011-05-13 17:52:57 +0000 |
1741 | +++ adjoint/Forward_Main_Loop.F90 2011-07-12 15:56:32 +0000 |
1742 | @@ -40,6 +40,7 @@ |
1743 | use adjoint_global_variables |
1744 | use adjoint_functional_evaluation |
1745 | use populate_state_module |
1746 | + use boundary_conditions_from_options |
1747 | use signal_vars |
1748 | use mangle_options_tree |
1749 | use mangle_dirichlet_rows_module |
1750 | @@ -53,12 +54,13 @@ |
1751 | implicit none |
1752 | |
1753 | private |
1754 | + public :: forward_main_loop_register_diagnostic |
1755 | #ifdef HAVE_ADJOINT |
1756 | - public :: compute_forward |
1757 | + public :: compute_forward, calculate_functional_values, register_functional_callbacks |
1758 | #endif |
1759 | |
1760 | -#ifdef HAVE_ADJOINT |
1761 | contains |
1762 | +#ifdef HAVE_ADJOINT |
1763 | |
1764 | subroutine compute_forward(state) |
1765 | type(state_type), dimension(:), intent(inout) :: state |
1766 | @@ -153,6 +155,11 @@ |
1767 | |
1768 | if (has_path) then |
1769 | sfield_soln%option_path = trim(path) |
1770 | + ! We need to populate the BC values: |
1771 | + call insert(state(1), sfield_soln, trim(sfield_soln%name)) |
1772 | + call populate_boundary_conditions(state) |
1773 | + call set_boundary_conditions_values(state, shift_time=.false.) |
1774 | + sfield_soln = extract_scalar_field(state(1), trim(sfield_soln%name)) |
1775 | end if |
1776 | |
1777 | select case(lhs%klass) |
1778 | @@ -168,6 +175,10 @@ |
1779 | call adj_chkierr(ierr) |
1780 | end if |
1781 | |
1782 | + sfield_rhs%bc => sfield_soln%bc |
1783 | + call set_dirichlet_consistent(sfield_rhs) |
1784 | + sfield_rhs%bc => null() |
1785 | + |
1786 | call petsc_solve(sfield_soln, csr_mat, sfield_rhs, option_path=path) |
1787 | call compute_inactive_rows(sfield_soln, csr_mat, sfield_rhs) |
1788 | endif |
1789 | @@ -178,6 +189,7 @@ |
1790 | end select |
1791 | |
1792 | call insert(state(1), sfield_soln, trim(sfield_soln%name)) |
1793 | + |
1794 | soln = field_to_adj_vector(sfield_soln) |
1795 | ierr = adj_storage_memory_incref(soln, storage) |
1796 | call adj_chkierr(ierr) |
1797 | @@ -197,6 +209,11 @@ |
1798 | |
1799 | if (has_path) then |
1800 | vfield_soln%option_path = trim(path) |
1801 | + ! We need to populate the BC values: |
1802 | + call insert(state(1), vfield_soln, trim(vfield_soln%name)) |
1803 | + call populate_boundary_conditions(state) |
1804 | + call set_boundary_conditions_values(state, shift_time=.false.) |
1805 | + vfield_soln = extract_vector_field(state(1), trim(vfield_soln%name)) |
1806 | end if |
1807 | |
1808 | select case(lhs%klass) |
1809 | @@ -212,6 +229,10 @@ |
1810 | call adj_chkierr(ierr) |
1811 | end if |
1812 | |
1813 | + vfield_rhs%bc => vfield_soln%bc |
1814 | + call set_dirichlet_consistent(vfield_rhs) |
1815 | + vfield_rhs%bc => null() |
1816 | + |
1817 | call petsc_solve(vfield_soln, csr_mat, vfield_rhs, option_path=path) |
1818 | !call compute_inactive_rows(vfield_soln, csr_mat, vfield_rhs) |
1819 | endif |
1820 | @@ -233,6 +254,7 @@ |
1821 | end select |
1822 | |
1823 | call insert(state(1), vfield_soln, trim(vfield_soln%name)) |
1824 | + |
1825 | soln = field_to_adj_vector(vfield_soln) |
1826 | ierr = adj_storage_memory_incref(soln, storage) |
1827 | call adj_chkierr(ierr) |
1828 | @@ -264,8 +286,17 @@ |
1829 | call set_prescribed_field_values(state, exclude_interpolated=.true., exclude_nonreprescribed=.true., time=current_time) |
1830 | call calculate_diagnostic_variables(state, exclude_nonrecalculated = .true.) |
1831 | call calculate_diagnostic_variables_new(state, exclude_nonrecalculated = .true.) |
1832 | + ! The first timestep is the initialisation of the model. |
1833 | + ! We skip the evaluation of the functional at timestep zero to get the correct value. |
1834 | + if (timestep > 0) then |
1835 | + call calculate_functional_values(timestep-1) |
1836 | + ! The last timestep is a the dummy timestep added at the end to act |
1837 | + ! as a container for the last equation |
1838 | + if (start_time == end_time) then |
1839 | + assert(timestep == no_timesteps-1) |
1840 | + end if |
1841 | + end if |
1842 | call write_diagnostics(state, current_time, dt, equation+1) |
1843 | - |
1844 | if (do_write_state(current_time, timestep)) then |
1845 | call write_state(dump_no, state) |
1846 | endif |
1847 | @@ -286,5 +317,69 @@ |
1848 | call get_option("/timestepping/finish_time", finish_time) |
1849 | assert(current_time == finish_time) |
1850 | end subroutine compute_forward |
1851 | -#endif |
1852 | + |
1853 | + subroutine register_functional_callbacks() |
1854 | + integer :: no_functionals, functional |
1855 | + character(len=ADJ_NAME_LEN) :: functional_name |
1856 | + integer :: ierr |
1857 | + |
1858 | + no_functionals = option_count("/adjoint/functional") |
1859 | + do functional=0,no_functionals-1 |
1860 | + if (have_option("/adjoint/functional[" // int2str(functional) // "]/functional_value")) then |
1861 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
1862 | + ! Register the callback to compute J |
1863 | + ierr = adj_register_functional_callback(adjointer, trim(functional_name), c_funloc(libadjoint_evaluate_functional)) |
1864 | + call adj_chkierr(ierr) |
1865 | + end if |
1866 | + end do |
1867 | + end subroutine register_functional_callbacks |
1868 | + |
1869 | + subroutine calculate_functional_values(timestep) |
1870 | + integer, intent(in) :: timestep |
1871 | + integer :: functional, no_functionals |
1872 | + character(len=OPTION_PATH_LEN) :: functional_name |
1873 | + real, dimension(:), pointer :: fn_value |
1874 | + real :: J |
1875 | + integer :: ierr |
1876 | + |
1877 | + no_functionals = option_count("/adjoint/functional") |
1878 | + do functional=0,no_functionals-1 |
1879 | + if (have_option("/adjoint/functional[" // int2str(functional) // "]/functional_value")) then |
1880 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
1881 | + ierr = adj_evaluate_functional(adjointer, timestep, functional_name, J) |
1882 | + call adj_chkierr(ierr) |
1883 | + ! So we've computed the component of the functional associated with this timestep. |
1884 | + ! We also want to sum them all up ... |
1885 | + call set_diagnostic(name=trim(functional_name) // "_component", statistic="value", value=(/J/)) |
1886 | + fn_value => get_diagnostic(name=trim(functional_name), statistic="value") |
1887 | + J = J + fn_value(1) |
1888 | + call set_diagnostic(name=trim(functional_name), statistic="value", value=(/J/)) |
1889 | + end if |
1890 | + end do |
1891 | + end subroutine calculate_functional_values |
1892 | + |
1893 | +#endif |
1894 | + |
1895 | + ! Register a diagnostic variable for each functional. |
1896 | + subroutine forward_main_loop_register_diagnostic |
1897 | + integer :: functional, no_functionals |
1898 | + character(len=OPTION_PATH_LEN) :: functional_name |
1899 | + |
1900 | +#ifdef HAVE_ADJOINT |
1901 | + no_functionals = option_count("/adjoint/functional") |
1902 | + |
1903 | + do functional=0,no_functionals-1 |
1904 | + ! Register a diagnostic for each functional |
1905 | + if (have_option("/adjoint/functional[" // int2str(functional) // "]/functional_value")) then |
1906 | + call get_option("/adjoint/functional[" // int2str(functional) // "]/name", functional_name) |
1907 | + call register_diagnostic(dim=1, name=trim(functional_name) // "_component", statistic="value") |
1908 | + call register_diagnostic(dim=1, name=trim(functional_name), statistic="value") |
1909 | + ! The functional value will be accumulated, so initialise it with zero. |
1910 | + call set_diagnostic(name=trim(functional_name) // "_component", statistic="value", value=(/0.0/)) |
1911 | + call set_diagnostic(name=trim(functional_name), statistic="value", value=(/0.0/)) |
1912 | + end if |
1913 | + end do |
1914 | +#endif |
1915 | + end subroutine forward_main_loop_register_diagnostic |
1916 | + |
1917 | end module forward_main_loop |
1918 | |
1919 | === modified file 'adjoint/Libadjoint_Data_Callbacks.F90' |
1920 | --- adjoint/Libadjoint_Data_Callbacks.F90 2011-05-24 10:42:33 +0000 |
1921 | +++ adjoint/Libadjoint_Data_Callbacks.F90 2011-07-12 15:56:32 +0000 |
1922 | @@ -88,6 +88,8 @@ |
1923 | call adj_chkierr(ierr) |
1924 | ierr = adj_register_data_callback(adjointer, ADJ_VEC_GET_NORM_CB, c_funloc(femtools_vec_getnorm_proc)) |
1925 | call adj_chkierr(ierr) |
1926 | + ierr = adj_register_data_callback(adjointer, ADJ_VEC_GET_SIZE_CB, c_funloc(femtools_vec_get_size_proc)) |
1927 | + call adj_chkierr(ierr) |
1928 | ierr = adj_register_data_callback(adjointer, ADJ_VEC_DOT_PRODUCT_CB, c_funloc(femtools_vec_dot_product_proc)) |
1929 | call adj_chkierr(ierr) |
1930 | ierr = adj_register_data_callback(adjointer, ADJ_VEC_SET_RANDOM_CB, c_funloc(femtools_vec_set_random_proc)) |
1931 | @@ -317,6 +319,27 @@ |
1932 | end if |
1933 | end subroutine femtools_vec_set_random_proc |
1934 | |
1935 | + subroutine femtools_vec_get_size_proc(vec, sz) bind(c) |
1936 | + type(adj_vector), intent(in), value :: vec |
1937 | + integer(kind=c_int), intent(out) :: sz |
1938 | + type(scalar_field), pointer :: scalar |
1939 | + type(vector_field), pointer :: vector |
1940 | + type(tensor_field), pointer :: tensor |
1941 | + |
1942 | + if (vec%klass == ADJ_SCALAR_FIELD) then |
1943 | + call c_f_pointer(vec%ptr, scalar) |
1944 | + sz = node_count(scalar) |
1945 | + else if (vec%klass == ADJ_VECTOR_FIELD) then |
1946 | + call c_f_pointer(vec%ptr, vector) |
1947 | + sz = node_count(vector) * vector%dim |
1948 | + else if (vec%klass == ADJ_TENSOR_FIELD) then |
1949 | + call c_f_pointer(vec%ptr, tensor) |
1950 | + sz = node_count(tensor) * tensor%dim(1) * tensor%dim(2) |
1951 | + else |
1952 | + FLAbort("adj_vector class not supported.") |
1953 | + end if |
1954 | + end subroutine femtools_vec_get_size_proc |
1955 | + |
1956 | subroutine femtools_mat_axpy_proc(Y, alpha, X) bind(c) |
1957 | ! Computes Y = alpha*X + Y. |
1958 | use iso_c_binding |
1959 | |
1960 | === modified file 'adjoint/Makefile.dependencies' |
1961 | --- adjoint/Makefile.dependencies 2011-05-23 14:44:04 +0000 |
1962 | +++ adjoint/Makefile.dependencies 2011-07-12 15:56:32 +0000 |
1963 | @@ -1,4 +1,12 @@ |
1964 | # Dependencies generated by create_makefile.py. DO NOT EDIT |
1965 | +../include/adjoint_controls.mod: Adjoint_Controls.o |
1966 | + @true |
1967 | + |
1968 | +Adjoint_Controls.o ../include/adjoint_controls.mod: Adjoint_Controls.F90 \ |
1969 | + ../include/boundary_conditions.mod ../include/global_parameters.mod \ |
1970 | + ../include/fields.mod ../include/spud.mod ../include/python_state.mod \ |
1971 | + ../include/fdebug.h ../include/state_module.mod |
1972 | + |
1973 | ../include/adjoint_functional_evaluation.mod: Adjoint_Functional_Evaluation.o |
1974 | @true |
1975 | |
1976 | @@ -22,7 +30,7 @@ |
1977 | |
1978 | Adjoint_Main_Loop.o ../include/adjoint_main_loop.mod: Adjoint_Main_Loop.F90 \ |
1979 | ../include/populate_state_module.mod ../include/sparse_matrices_fields.mod \ |
1980 | - ../include/diagnostic_fields_new.mod \ |
1981 | + ../include/diagnostic_fields_new.mod ../include/adjoint_controls.mod \ |
1982 | ../include/adjoint_functional_evaluation.mod ../include/sparse_tools.mod \ |
1983 | ../include/fields.mod ../include/diagnostic_variables.mod \ |
1984 | ../include/mangle_options_tree.mod ../include/write_state_module.mod \ |
1985 | @@ -44,12 +52,25 @@ |
1986 | |
1987 | Burgers_Adjoint_Callbacks.o ../include/burgers_adjoint_callbacks.mod: \ |
1988 | Burgers_Adjoint_Callbacks.F90 ../include/libadjoint_data_callbacks.mod \ |
1989 | - ../include/adjoint_global_variables.mod ../include/fields.mod \ |
1990 | - ../include/spud.mod ../include/mangle_options_tree.mod \ |
1991 | - ../include/sparse_matrices_fields.mod \ |
1992 | - ../include/mangle_dirichlet_rows_module.mod ../include/fdebug.h \ |
1993 | + ../include/simple_advection.mod ../include/burgers_assembly.mod \ |
1994 | + ../include/populate_state_module.mod \ |
1995 | + ../include/adjoint_global_variables.mod ../include/global_parameters.mod \ |
1996 | + ../include/fields.mod ../include/simple_advection_b.mod ../include/spud.mod \ |
1997 | + ../include/mangle_options_tree.mod ../include/sparse_matrices_fields.mod \ |
1998 | + ../include/mangle_dirichlet_rows_module.mod \ |
1999 | + ../include/simple_advection_d.mod ../include/fdebug.h \ |
2000 | ../include/state_module.mod |
2001 | |
2002 | +../include/burgers_adjoint_controls.mod: Burgers_Control_Callbacks.o |
2003 | + @true |
2004 | + |
2005 | +Burgers_Control_Callbacks.o ../include/burgers_adjoint_controls.mod: \ |
2006 | + Burgers_Control_Callbacks.F90 ../include/mangle_dirichlet_rows_module.mod \ |
2007 | + ../include/manifold_projections.mod ../include/global_parameters.mod \ |
2008 | + ../include/fields.mod ../include/spud.mod \ |
2009 | + ../include/sparse_matrices_fields.mod ../include/state_module.mod \ |
2010 | + ../include/python_state.mod ../include/fdebug.h |
2011 | + |
2012 | ../include/forward_main_loop.mod: Forward_Main_Loop.o |
2013 | @true |
2014 | |
2015 | @@ -58,6 +79,7 @@ |
2016 | ../include/diagnostic_fields_new.mod \ |
2017 | ../include/adjoint_functional_evaluation.mod ../include/sparse_tools.mod \ |
2018 | ../include/fields.mod ../include/diagnostic_variables.mod \ |
2019 | + ../include/boundary_conditions_from_options.mod \ |
2020 | ../include/mangle_options_tree.mod ../include/write_state_module.mod \ |
2021 | ../include/spud.mod ../include/mangle_dirichlet_rows_module.mod \ |
2022 | ../include/state_module.mod ../include/libadjoint_data_callbacks.mod \ |
2023 | @@ -105,3 +127,14 @@ |
2024 | ../include/manifold_projections.mod ../include/fdebug.h \ |
2025 | ../include/state_module.mod |
2026 | |
2027 | +../include/shallow_water_adjoint_controls.mod: \ |
2028 | + Shallow_Water_Control_Callbacks.o |
2029 | + @true |
2030 | + |
2031 | +Shallow_Water_Control_Callbacks.o \ |
2032 | + ../include/shallow_water_adjoint_controls.mod: \ |
2033 | + Shallow_Water_Control_Callbacks.F90 ../include/manifold_projections.mod \ |
2034 | + ../include/global_parameters.mod ../include/fields.mod ../include/spud.mod \ |
2035 | + ../include/sparse_matrices_fields.mod ../include/python_state.mod \ |
2036 | + ../include/fdebug.h ../include/state_module.mod |
2037 | + |
2038 | |
2039 | === modified file 'adjoint/Makefile.in' |
2040 | --- adjoint/Makefile.in 2011-05-19 14:29:56 +0000 |
2041 | +++ adjoint/Makefile.in 2011-07-12 15:56:32 +0000 |
2042 | @@ -43,10 +43,16 @@ |
2043 | |
2044 | LIB = ../lib/lib@FLUIDITY@.a |
2045 | |
2046 | -OBJS = $(patsubst %.F90,%.o,$(wildcard *.F90)) $(patsubst %.c,%.o,$(wildcard *.c)) |
2047 | - |
2048 | -.SUFFIXES: .F90 .c .cpp .o .a |
2049 | - |
2050 | +OBJS = $(patsubst %.F90,%.o,$(wildcard *.F90)) $(patsubst %.f90,%.o,$(wildcard *.f90)) $(patsubst %.c,%.o,$(wildcard *.c)) $(patsubst %.f,%.o,$(wildcard *.f)) |
2051 | + |
2052 | +.SUFFIXES: .f .f90 .F90 .c .cpp .o .a |
2053 | + |
2054 | +.f90.o: |
2055 | + @echo " FC $<" |
2056 | + $(FC) $(FCFLAGS) $(GENFLAGS) -c $< |
2057 | +.f.o: |
2058 | + @echo " FC $<" |
2059 | + $(FC) $(FCFLAGS) $(GENFLAGS) -c $< |
2060 | .F90.o: |
2061 | @echo " FC $<" |
2062 | $(FC) $(FCFLAGS) $(GENFLAGS) -c $< |
2063 | @@ -71,4 +77,16 @@ |
2064 | clean: |
2065 | rm -f *.o *.d *.mod |
2066 | |
2067 | +# Instructions for doing AD with tapenade |
2068 | +reverse: |
2069 | + tapenade -b -head "advection_action" -outvars "ac" -vars "u" simple_advection.f90 -ext PUSHPOPGeneralLib -extAD PUSHPOPADLib-fixinterface |
2070 | + echo "Don't forget to remove the zeroing of acb." |
2071 | + |
2072 | +forward: |
2073 | + tapenade -d -head "advection_action" -outvars "ac" -vars "u" simple_advection.f90 |
2074 | + |
2075 | +../include/simple_advection.mod: simple_advection.o |
2076 | +../include/simple_advection_d.mod: simple_advection_d.o |
2077 | +../include/simple_advection_b.mod: simple_advection_b.o |
2078 | + |
2079 | include Makefile.dependencies |
2080 | |
2081 | === modified file 'adjoint/Mangle_Dirichlet_Rows_Module.F90' |
2082 | --- adjoint/Mangle_Dirichlet_Rows_Module.F90 2011-03-31 17:44:57 +0000 |
2083 | +++ adjoint/Mangle_Dirichlet_Rows_Module.F90 2011-07-12 15:56:32 +0000 |
2084 | @@ -35,7 +35,7 @@ |
2085 | implicit none |
2086 | |
2087 | interface mangle_dirichlet_rows |
2088 | - module procedure mangle_dirichlet_rows_csr_scalar |
2089 | + module procedure mangle_dirichlet_rows_csr_scalar, mangle_dirichlet_rows_scalar |
2090 | end interface |
2091 | |
2092 | interface set_inactive_rows |
2093 | @@ -90,6 +90,28 @@ |
2094 | end do |
2095 | end subroutine mangle_dirichlet_rows_csr_scalar |
2096 | |
2097 | + subroutine mangle_dirichlet_rows_scalar(scalar, bc_field) |
2098 | + type(scalar_field), intent(inout) :: scalar |
2099 | + type(scalar_field), intent(in) :: bc_field |
2100 | + |
2101 | + integer :: i, j, node |
2102 | + character(len=FIELD_NAME_LEN) :: bctype |
2103 | + integer, dimension(:), pointer :: node_list |
2104 | + |
2105 | + assert(node_count(scalar) == node_count(bc_field)) |
2106 | + |
2107 | + do i=1,get_boundary_condition_count(bc_field) |
2108 | + call get_boundary_condition(bc_field, i, type=bctype, surface_node_list=node_list) |
2109 | + |
2110 | + if (bctype /= "dirichlet") cycle |
2111 | + |
2112 | + do j=1,size(node_list) |
2113 | + node = node_list(j) |
2114 | + call set(scalar, node, 0.0) |
2115 | + end do |
2116 | + end do |
2117 | + end subroutine mangle_dirichlet_rows_scalar |
2118 | + |
2119 | subroutine set_inactive_rows_csr_scalar(matrix, field) |
2120 | ! Any nodes associated with Dirichlet BCs, we make them inactive |
2121 | type(csr_matrix), intent(inout) :: matrix |
2122 | |
2123 | === modified file 'adjoint/Mangle_Options_Tree.F90' |
2124 | --- adjoint/Mangle_Options_Tree.F90 2011-03-10 10:07:19 +0000 |
2125 | +++ adjoint/Mangle_Options_Tree.F90 2011-07-12 15:56:32 +0000 |
2126 | @@ -139,12 +139,6 @@ |
2127 | deallocate(fields_to_delete) |
2128 | end do |
2129 | |
2130 | - ! We delete this because if it exists in the forward run, |
2131 | - ! write_diagnostics wants to print it out in the stat file. |
2132 | - do functional=0,option_count("/adjoint/functional")-1 |
2133 | - call delete_option("/adjoint/functional[" // int2str(functional) // "]/functional_value", stat=stat) |
2134 | - end do |
2135 | - |
2136 | end subroutine mangle_options_tree_forward |
2137 | |
2138 | subroutine mangle_options_tree_adjoint |
2139 | @@ -262,8 +256,13 @@ |
2140 | path = "/material_phase[" // int2str(state) // "]/scalar_field::" |
2141 | call move_option(trim(path) // trim(fields_to_move(field)), trim(path) // "Adjoint" // trim(fields_to_move(field)), stat=stat) |
2142 | assert(stat == SPUD_NO_ERROR) |
2143 | - ! Delete any sources specified for the forward model -- we deal with these ourselves |
2144 | - call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/scalar_field::Source", stat=stat) |
2145 | + ! Delete the sources specified for the forward model -- if desired |
2146 | + if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/scalar_field::Source/")) then |
2147 | + if (have_option(trim(complete_field_path(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/scalar_field::Source/")) & |
2148 | + & // "adjoint_storage/exists_in_forward")) then |
2149 | + call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/scalar_field::Source", stat=stat) |
2150 | + end if |
2151 | + end if |
2152 | ! And delete any initial conditions -- we will also specify these |
2153 | if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition")) then |
2154 | call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition", stat=stat) |
2155 | @@ -294,7 +293,12 @@ |
2156 | call move_option(trim(path) // trim(fields_to_move(field)), trim(path) // "Adjoint" // trim(fields_to_move(field)), stat=stat) |
2157 | assert(stat == SPUD_NO_ERROR) |
2158 | ! Delete any sources specified for the forward model -- we deal with these ourselves |
2159 | - call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/vector_field::Source", stat=stat) |
2160 | + if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/vector_field::Source/")) then |
2161 | + if (have_option(trim(complete_field_path(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/vector_field::Source/")) & |
2162 | + & // "adjoint_storage/exists_in_forward")) then |
2163 | + call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/vector_field::Source", stat=stat) |
2164 | + end if |
2165 | + end if |
2166 | ! And delete any initial conditions -- we will also specify these |
2167 | if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition")) then |
2168 | call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition", stat=stat) |
2169 | @@ -325,7 +329,12 @@ |
2170 | call move_option(trim(path) // trim(fields_to_move(field)), trim(path) // "Adjoint" // trim(fields_to_move(field)), stat=stat) |
2171 | assert(stat == SPUD_NO_ERROR) |
2172 | ! Delete any sources specified for the forward model -- we deal with these ourselves |
2173 | - call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/tensor_field::Source", stat=stat) |
2174 | + if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/tensor_field::Source/")) then |
2175 | + if (have_option(trim(complete_field_path(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/tensor_field::Source/")) & |
2176 | + & // "adjoint_storage/exists_in_forward")) then |
2177 | + call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/tensor_field::Source", stat=stat) |
2178 | + end if |
2179 | + end if |
2180 | ! And delete any initial conditions -- we will also specify these |
2181 | if (have_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition")) then |
2182 | call delete_option(trim(path) // "Adjoint" // trim(fields_to_move(field)) // "/prognostic/initial_condition", stat=stat) |
2183 | |
2184 | === modified file 'adjoint/Shallow_Water_Adjoint_Callbacks.F90' |
2185 | --- adjoint/Shallow_Water_Adjoint_Callbacks.F90 2011-05-13 14:06:12 +0000 |
2186 | +++ adjoint/Shallow_Water_Adjoint_Callbacks.F90 2011-07-12 15:56:32 +0000 |
2187 | @@ -982,5 +982,6 @@ |
2188 | end select |
2189 | end if |
2190 | end subroutine shallow_water_forward_source |
2191 | + |
2192 | #endif |
2193 | end module shallow_water_adjoint_callbacks |
2194 | |
2195 | === added file 'adjoint/Shallow_Water_Control_Callbacks.F90' |
2196 | --- adjoint/Shallow_Water_Control_Callbacks.F90 1970-01-01 00:00:00 +0000 |
2197 | +++ adjoint/Shallow_Water_Control_Callbacks.F90 2011-07-12 15:56:32 +0000 |
2198 | @@ -0,0 +1,203 @@ |
2199 | +! Copyright (C) 2006 Imperial College London and others. |
2200 | +! |
2201 | +! Please see the AUTHORS file in the main source directory for a full list |
2202 | +! of copyright holders. |
2203 | +! |
2204 | +! Prof. C Pain |
2205 | +! Applied Modelling and Computation Group |
2206 | +! Department of Earth Science and Engineering |
2207 | +! Imperial College London |
2208 | +! |
2209 | +! amcgsoftware@imperial.ac.uk |
2210 | +! |
2211 | +! This library is free software; you can redistribute it and/or |
2212 | +! modify it under the terms of the GNU Lesser General Public |
2213 | +! License as published by the Free Software Foundation, |
2214 | +! version 2.1 of the License. |
2215 | +! |
2216 | +! This library is distributed in the hope that it will be useful, |
2217 | +! but WITHOUT ANY WARRANTY; without even the implied warranty of |
2218 | +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
2219 | +! Lesser General Public License for more details. |
2220 | +! |
2221 | +! You should have received a copy of the GNU Lesser General Public |
2222 | +! License along with this library; if not, write to the Free Software |
2223 | +! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
2224 | +! USA |
2225 | + |
2226 | +#include "fdebug.h" |
2227 | + |
2228 | +module shallow_water_adjoint_controls |
2229 | + use fields |
2230 | + use global_parameters, only : PYTHON_FUNC_LEN, OPTION_PATH_LEN |
2231 | + use spud |
2232 | + use state_module |
2233 | + use python_state |
2234 | + use sparse_matrices_fields |
2235 | + use manifold_projections |
2236 | + |
2237 | + implicit none |
2238 | + |
2239 | + private |
2240 | + |
2241 | + public :: shallow_water_adjoint_timestep_callback |
2242 | + |
2243 | + contains |
2244 | + |
2245 | + ! Data is a void pointer used to pass variables into the callback |
2246 | + subroutine shallow_water_adjoint_timestep_callback(states, timestep, functional_name, data) |
2247 | + use iso_c_binding, only: c_ptr |
2248 | + use global_parameters, only: OPTION_PATH_LEN |
2249 | + use state_module |
2250 | + type(state_type), dimension(:), intent(inout) :: states |
2251 | + integer, intent(in) :: timestep |
2252 | + character(len=*), intent(in) :: functional_name |
2253 | + type(c_ptr), intent(in) :: data |
2254 | + |
2255 | + type(state_type), pointer :: matrices |
2256 | + character(len=OPTION_PATH_LEN) :: field_name, control_type, control_deriv_name, field_deriv_name, name, material_phase_name |
2257 | + integer :: nb_controls |
2258 | + integer :: i, state_id, s_idx |
2259 | + type(scalar_field), pointer :: sfield, adj_sfield, adj_sfield2 |
2260 | + type(vector_field), pointer :: vfield, adj_vfield, positions |
2261 | + type(tensor_field), pointer :: tfield, adj_tfield |
2262 | + type(block_csr_matrix), pointer :: big_mat, div_mat, u_mass_mat |
2263 | + type(csr_matrix), pointer :: h_mass_mat |
2264 | + |
2265 | + type(vector_field) :: local_src_tmp, local_src_tmp2, src_tmp |
2266 | + real :: theta, d0, dt |
2267 | + |
2268 | + ! Cast the data to the matrices state |
2269 | + call c_f_pointer(data, matrices) |
2270 | + |
2271 | + |
2272 | + nb_controls = option_count("/adjoint/controls/control") |
2273 | + do i = 0, nb_controls-1 |
2274 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/name", control_deriv_name) |
2275 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type/name", control_type) |
2276 | + call get_option("/adjoint/controls/control[" // int2str(i) //"]/type::" // trim(control_type) // "/field_name", name) |
2277 | + s_idx = scan(trim(name), "::") |
2278 | + if (s_idx == 0) then |
2279 | + FLAbort("The control " // trim(control_deriv_name) // " uses an invalid field_name. It should be of the form Materialphase::Fieldname") |
2280 | + end if |
2281 | + material_phase_name = name(1:s_idx - 1) |
2282 | + field_name = name(s_idx + 2:len_trim(name)) |
2283 | + ! Find state associated with the material phase |
2284 | + do state_id = 1, size(states) |
2285 | + if (trim(states(state_id)%name) == trim(material_phase_name)) then |
2286 | + exit |
2287 | + end if |
2288 | + end do |
2289 | + ! Make sure we found the state |
2290 | + if (.not. trim(states(state_id)%name) == trim(material_phase_name)) then |
2291 | + FLAbort("Could not find state " // trim(material_phase_name) // " as specified in control " // trim(control_deriv_name) // ".") |
2292 | + end if |
2293 | + |
2294 | + control_deriv_name = trim(control_deriv_name) // "_TotalDerivative" |
2295 | + select case(trim(control_type)) |
2296 | + !!!!!!!!!!!!! Initial condition !!!!!!!!!!!! |
2297 | + case ("initial_condition") |
2298 | + if (timestep /= 0) then |
2299 | + cycle |
2300 | + end if |
2301 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
2302 | + if (has_scalar_field(states(state_id), field_deriv_name)) then |
2303 | + if (trim(field_name) == "LayerThickness") then |
2304 | + adj_sfield => extract_scalar_field(states(state_id), "Adjoint" // trim(field_name)) |
2305 | + sfield => extract_scalar_field(states(state_id), field_deriv_name) ! Output field |
2306 | + h_mass_mat => extract_csr_matrix(matrices, "LayerThicknessMassMatrix") |
2307 | + call mult(sfield, h_mass_mat, adj_sfield) |
2308 | + else |
2309 | + FLAbort("Sorry, I do not know how to compute the intial condition control for " // trim(field_name) // ".") |
2310 | + end if |
2311 | + elseif (has_vector_field(states(state_id), field_deriv_name)) then |
2312 | + if (trim(field_name) == "Velocity") then |
2313 | + adj_vfield => extract_vector_field(states(state_id), "Adjoint" // trim(field_name)) |
2314 | + vfield => extract_vector_field(states(state_id), field_deriv_name) ! Output field |
2315 | + u_mass_mat => extract_block_csr_matrix(matrices, "CartesianVelocityMassMatrix") |
2316 | + call mult(vfield, u_mass_mat, adj_vfield) |
2317 | + else |
2318 | + FLAbort("Sorry, I do not know how to compute the intial condition control for " // trim(field_name) // ".") |
2319 | + end if |
2320 | + elseif (has_tensor_field(states(state_id), field_deriv_name)) then |
2321 | + tfield => extract_tensor_field(states(state_id), field_deriv_name) ! Output field |
2322 | + FLAbort("Sorry, I do not know how to compute the intial condition control for " // trim(field_name) // ".") |
2323 | + else |
2324 | + FLAbort("The control derivative field " // trim(field_deriv_name) // " specified for " // trim(control_deriv_name) // " is not a field in the state.") |
2325 | + end if |
2326 | + !!!!!!!!!!!!! Boundary condition !!!!!!!!!!!! |
2327 | + case("boundary_condition") |
2328 | + FLAbort("Boundary condition control not implemented yet.") |
2329 | + !!!!!!!!!!!!! Source !!!!!!!!!!!! |
2330 | + case("source_term") |
2331 | + if (timestep == 0) then |
2332 | + cycle |
2333 | + end if |
2334 | + field_deriv_name = trim(functional_name) // "_" // control_deriv_name |
2335 | + call get_option("/timestepping/timestep", dt) |
2336 | + if (has_scalar_field(states(state_id), field_deriv_name)) then |
2337 | + if (trim(field_name) == "LayerThicknessSource") then |
2338 | + adj_sfield => extract_scalar_field(states(state_id), "AdjointLayerThicknessDelta") |
2339 | + sfield => extract_scalar_field(states(state_id), field_deriv_name) ! Output field |
2340 | + h_mass_mat => extract_csr_matrix(matrices, "LayerThicknessMassMatrix") |
2341 | + call mult_T(sfield, h_mass_mat, adj_sfield) |
2342 | + call scale(sfield, abs(dt)) |
2343 | + else |
2344 | + FLAbort("Sorry, I do not know how to compute the source condition control for " // trim(field_name) // ".") |
2345 | + end if |
2346 | + elseif (has_vector_field(states(state_id), field_deriv_name)) then |
2347 | + if (trim(field_name) == "VelocitySource") then |
2348 | + ! We want to compute: |
2349 | + ! \lambda_{delta \eta} \Delta t^2 d_0 \theta C^T (M+\theta \Delta t L)^{-1} M P_{Cart to local} |
2350 | + vfield => extract_vector_field(states(state_id), field_deriv_name) ! Output field |
2351 | + adj_sfield => extract_scalar_field(states(state_id), "AdjointLayerThicknessDelta") |
2352 | + adj_vfield => extract_vector_field(states(state_id), "AdjointLocalVelocityDelta") |
2353 | + ! We need the AdjointVelocity for the option path only |
2354 | + adj_sfield2 => extract_scalar_field(states(state_id), "AdjointLayerThickness") |
2355 | + call get_option(trim(adj_sfield2%option_path) // "/prognostic/temporal_discretisation/theta", theta) |
2356 | + call get_option(trim(adj_sfield2%option_path) // "/prognostic/mean_layer_thickness", d0) |
2357 | + |
2358 | + big_mat => extract_block_csr_matrix(matrices, "InverseBigMatrix") |
2359 | + div_mat => extract_block_csr_matrix(matrices, "DivergenceMatrix") |
2360 | + h_mass_mat => extract_csr_matrix(matrices, "LayerThicknessMassMatrix") |
2361 | + u_mass_mat => extract_block_csr_matrix(matrices, "LocalVelocityMassMatrix") |
2362 | + positions => extract_vector_field(matrices, "Coordinate") |
2363 | + |
2364 | + call allocate(local_src_tmp, adj_vfield%dim, adj_vfield%mesh, "TemporaryLocalVelocity") |
2365 | + call allocate(local_src_tmp2, adj_vfield%dim, adj_vfield%mesh, "TemporaryLocalVelocity2") |
2366 | + call allocate(src_tmp, vfield%dim, vfield%mesh, "TemporaryVelocity") |
2367 | + call mult_T(local_src_tmp, div_mat, adj_sfield) |
2368 | + call mult_T(local_src_tmp2, big_mat, local_src_tmp) |
2369 | + call mult_T(local_src_tmp, u_mass_mat, local_src_tmp2) |
2370 | + call project_cartesian_to_local(positions, src_tmp, local_src_tmp, transpose=.true.) |
2371 | + call scale(src_tmp, factor = dt*dt * d0 * theta) |
2372 | + call zero(vfield) |
2373 | + ! TODO: Where does this minus come from? |
2374 | + call addto(vfield, src_tmp, scale=-1.0) |
2375 | + |
2376 | + ! Now add the part from \lambda_{\Delta u} |
2377 | + ! \lambda_{\Delta u} M M_{big} M P_{cart to local} |
2378 | + call mult_T(local_src_tmp, u_mass_mat, adj_vfield) |
2379 | + call mult_T(local_src_tmp2, big_mat, local_src_tmp) |
2380 | + call mult_T(local_src_tmp, u_mass_mat, local_src_tmp2) |
2381 | + call project_cartesian_to_local(positions, src_tmp, local_src_tmp, transpose = .true.) |
2382 | + call addto(vfield, src_tmp, scale = abs(dt)) |
2383 | + |
2384 | + call deallocate(local_src_tmp) |
2385 | + call deallocate(local_src_tmp2) |
2386 | + call deallocate(src_tmp) |
2387 | + else |
2388 | + FLAbort("Sorry, I do not know how to compute the source condition control for " // trim(field_name) // ".") |
2389 | + end if |
2390 | + elseif (has_tensor_field(states(state_id), field_deriv_name)) then |
2391 | + tfield => extract_tensor_field(states(state_id), field_deriv_name) ! Output field |
2392 | + FLAbort("Sorry, I do not know how to compute the source condition control for " // trim(field_name) // ".") |
2393 | + else |
2394 | + FLAbort("The control derivative field " // trim(field_deriv_name) // " specified for " // trim(control_deriv_name) // " is not a field in the state.") |
2395 | + end if |
2396 | + end select |
2397 | + end do |
2398 | + |
2399 | + end subroutine shallow_water_adjoint_timestep_callback |
2400 | + |
2401 | +end module shallow_water_adjoint_controls |
2402 | |
2403 | === added file 'adjoint/adBuffer.c' |
2404 | --- adjoint/adBuffer.c 1970-01-01 00:00:00 +0000 |
2405 | +++ adjoint/adBuffer.c 2011-07-12 15:56:32 +0000 |
2406 | @@ -0,0 +1,476 @@ |
2407 | +static char adSid[]="$Id: adBuffer.c $"; |
2408 | + |
2409 | +#include <stdlib.h> |
2410 | +#include <stdio.h> |
2411 | +#include <string.h> |
2412 | + |
2413 | +#include "adStack.h" |
2414 | + |
2415 | +/************ MEASUREMENT OF PUSH/POP TRAFFIC *************/ |
2416 | + |
2417 | +static int mmftraffic = 0 ; |
2418 | +static int mmftrafficM = 0 ; |
2419 | + |
2420 | +void addftraffic(int n) { |
2421 | + mmftraffic = mmftraffic+n ; |
2422 | + while (mmftraffic >= 1000000) { |
2423 | + mmftraffic = mmftraffic-1000000 ; |
2424 | + ++mmftrafficM ; |
2425 | + } |
2426 | + while (mmftraffic < 0) { |
2427 | + mmftraffic = mmftraffic+1000000 ; |
2428 | + --mmftraffic ; |
2429 | + } |
2430 | +} |
2431 | + |
2432 | +void printtraffic() { |
2433 | + printctraffic_() ; |
2434 | + printf(" F Traffic: ") ; |
2435 | + printbigbytes(mmftrafficM, 1000000, mmftraffic) ; |
2436 | + printf(" bytes\n") ; |
2437 | +} |
2438 | + |
2439 | +/************************** integer*4 ************************/ |
2440 | +static int adi4buf[512] ; |
2441 | +static int adi4ibuf = 0 ; |
2442 | +static int adi4lbuf[512] ; |
2443 | +static int adi4ilbuf = -1 ; |
2444 | +static int adi4inlbuf = 0 ; |
2445 | + |
2446 | +void pushinteger4(int x) { |
2447 | + addftraffic(4) ; |
2448 | + if (adi4ilbuf != -1) { |
2449 | + adi4ilbuf = -1 ; |
2450 | + adi4inlbuf = 0 ; |
2451 | + } |
2452 | + if (adi4ibuf >= 511) { |
2453 | + adi4buf[511] = x ; |
2454 | + pushNarray((char*)adi4buf, 512*4) ; |
2455 | + addftraffic(-512*4) ; |
2456 | + adi4ibuf = 0 ; |
2457 | + } else { |
2458 | + adi4buf[adi4ibuf] = x ; |
2459 | + ++adi4ibuf ; |
2460 | + } |
2461 | +} |
2462 | + |
2463 | +void lookinteger4(int *x) { |
2464 | + if (adi4ilbuf == -1) { |
2465 | + adi4ilbuf = adi4ibuf ; |
2466 | + resetadlookstack_() ; |
2467 | + } |
2468 | + if (adi4ilbuf <= 0) { |
2469 | + lookNarray((char*)adi4lbuf, 512*4) ; |
2470 | + adi4inlbuf = 1 ; |
2471 | + adi4ilbuf = 511 ; |
2472 | + *x = adi4lbuf[511] ; |
2473 | + } else { |
2474 | + --adi4ilbuf ; |
2475 | + if (adi4inlbuf) |
2476 | + *x = adi4lbuf[adi4ilbuf] ; |
2477 | + else |
2478 | + *x = adi4buf[adi4ilbuf] ; |
2479 | + } |
2480 | +} |
2481 | + |
2482 | +void popinteger4(int *x) { |
2483 | + if (adi4ilbuf != -1) { |
2484 | + adi4ilbuf = -1 ; |
2485 | + adi4inlbuf = 0 ; |
2486 | + } |
2487 | + if (adi4ibuf <= 0) { |
2488 | + popNarray((char*)adi4buf, 512*4) ; |
2489 | + adi4ibuf = 511 ; |
2490 | + *x = adi4buf[511] ; |
2491 | + } else { |
2492 | + --adi4ibuf ; |
2493 | + *x = adi4buf[adi4ibuf] ; |
2494 | + } |
2495 | +} |
2496 | + |
2497 | +/*************************** bits *************************/ |
2498 | +static unsigned int adbitbuf = 0 ; |
2499 | +static int adbitibuf = 1 ; |
2500 | +static unsigned int adbitlbuf = 0 ; |
2501 | +static int adbitilbuf = -1 ; |
2502 | +static int adbitinlbuf = 0 ; |
2503 | + |
2504 | +void pushbit(int bit) { |
2505 | + if (adbitilbuf != -1) { |
2506 | + adbitilbuf = -1 ; |
2507 | + adbitinlbuf = 0 ; |
2508 | + } |
2509 | + adbitbuf<<=1 ; |
2510 | + if (bit) adbitbuf++ ; |
2511 | + if (adbitibuf>=32) { |
2512 | + pushinteger4(adbitbuf) ; |
2513 | + adbitbuf = 0 ; |
2514 | + adbitibuf = 1 ; |
2515 | + } else |
2516 | + adbitibuf++ ; |
2517 | +} |
2518 | + |
2519 | +int lookbit() { |
2520 | + if (adbitilbuf==-1) { |
2521 | + adbitilbuf=adbitibuf ; |
2522 | + adbitlbuf = adbitbuf ; |
2523 | + } |
2524 | + if (adbitilbuf<=1) { |
2525 | + lookinteger4(&adbitlbuf) ; |
2526 | + adbitilbuf = 32 ; |
2527 | + } else |
2528 | + adbitilbuf-- ; |
2529 | + int bit = adbitlbuf%2 ; |
2530 | + adbitlbuf>>=1 ; |
2531 | + return bit ; |
2532 | +} |
2533 | + |
2534 | +int popbit() { |
2535 | + if (adbitilbuf != -1) { |
2536 | + adbitilbuf = -1 ; |
2537 | + adbitinlbuf = 0 ; |
2538 | + } |
2539 | + if (adbitibuf<=1) { |
2540 | + popinteger4(&adbitbuf) ; |
2541 | + adbitibuf = 32 ; |
2542 | + } else |
2543 | + adbitibuf-- ; |
2544 | + int bit = adbitbuf%2 ; |
2545 | + adbitbuf>>=1 ; |
2546 | + return bit ; |
2547 | +} |
2548 | + |
2549 | +/************************* controls ***********************/ |
2550 | + |
2551 | +void pushcontrol1b(int cc) { |
2552 | + pushbit(cc) ; |
2553 | +} |
2554 | + |
2555 | +void popcontrol1b(int *cc) { |
2556 | + *cc = (popbit()?1:0) ; |
2557 | +} |
2558 | + |
2559 | +void lookcontrol1b(int *cc) { |
2560 | + *cc = (lookbit()?1:0) ; |
2561 | +} |
2562 | + |
2563 | +void pushcontrol2b(int cc) { |
2564 | + pushbit(cc%2) ; |
2565 | + cc >>= 1 ; |
2566 | + pushbit(cc) ; |
2567 | +} |
2568 | + |
2569 | +void popcontrol2b(int *cc) { |
2570 | + *cc = (popbit()?2:0) ; |
2571 | + if (popbit()) (*cc)++ ; |
2572 | +} |
2573 | + |
2574 | +void lookcontrol2b(int *cc) { |
2575 | + *cc = (lookbit()?2:0) ; |
2576 | + if (lookbit()) (*cc)++ ; |
2577 | +} |
2578 | + |
2579 | +void pushcontrol3b(int cc) { |
2580 | + pushbit(cc%2) ; |
2581 | + cc >>= 1 ; |
2582 | + pushbit(cc%2) ; |
2583 | + cc >>= 1 ; |
2584 | + pushbit(cc) ; |
2585 | +} |
2586 | + |
2587 | +void popcontrol3b(int *cc) { |
2588 | + *cc = (popbit()?2:0) ; |
2589 | + if (popbit()) (*cc)++ ; |
2590 | + (*cc) <<= 1 ; |
2591 | + if (popbit()) (*cc)++ ; |
2592 | +} |
2593 | + |
2594 | +void lookcontrol3b(int *cc) { |
2595 | + *cc = (lookbit()?2:0) ; |
2596 | + if (lookbit()) (*cc)++ ; |
2597 | + (*cc) <<= 1 ; |
2598 | + if (lookbit()) (*cc)++ ; |
2599 | +} |
2600 | + |
2601 | +void pushcontrol4b(int cc) { |
2602 | + pushbit(cc%2) ; |
2603 | + cc >>= 1 ; |
2604 | + pushbit(cc%2) ; |
2605 | + cc >>= 1 ; |
2606 | + pushbit(cc%2) ; |
2607 | + cc >>= 1 ; |
2608 | + pushbit(cc) ; |
2609 | +} |
2610 | + |
2611 | +void popcontrol4b(int *cc) { |
2612 | + *cc = (popbit()?2:0) ; |
2613 | + if (popbit()) (*cc)++ ; |
2614 | + (*cc) <<= 1 ; |
2615 | + if (popbit()) (*cc)++ ; |
2616 | + (*cc) <<= 1 ; |
2617 | + if (popbit()) (*cc)++ ; |
2618 | +} |
2619 | + |
2620 | +void lookcontrol4b(int *cc) { |
2621 | + *cc = (lookbit()?2:0) ; |
2622 | + if (lookbit()) (*cc)++ ; |
2623 | + (*cc) <<= 1 ; |
2624 | + if (lookbit()) (*cc)++ ; |
2625 | + (*cc) <<= 1 ; |
2626 | + if (lookbit()) (*cc)++ ; |
2627 | +} |
2628 | + |
2629 | +void pushcontrol5b(int cc) { |
2630 | + pushbit(cc%2) ; |
2631 | + cc >>= 1 ; |
2632 | + pushbit(cc%2) ; |
2633 | + cc >>= 1 ; |
2634 | + pushbit(cc%2) ; |
2635 | + cc >>= 1 ; |
2636 | + pushbit(cc%2) ; |
2637 | + cc >>= 1 ; |
2638 | + pushbit(cc) ; |
2639 | +} |
2640 | + |
2641 | +void popcontrol5b(int *cc) { |
2642 | + *cc = (popbit()?2:0) ; |
2643 | + if (popbit()) (*cc)++ ; |
2644 | + (*cc) <<= 1 ; |
2645 | + if (popbit()) (*cc)++ ; |
2646 | + (*cc) <<= 1 ; |
2647 | + if (popbit()) (*cc)++ ; |
2648 | + (*cc) <<= 1 ; |
2649 | + if (popbit()) (*cc)++ ; |
2650 | +} |
2651 | + |
2652 | +void lookcontrol5b(int *cc) { |
2653 | + *cc = (lookbit()?2:0) ; |
2654 | + if (lookbit()) (*cc)++ ; |
2655 | + (*cc) <<= 1 ; |
2656 | + if (lookbit()) (*cc)++ ; |
2657 | + (*cc) <<= 1 ; |
2658 | + if (lookbit()) (*cc)++ ; |
2659 | + (*cc) <<= 1 ; |
2660 | + if (lookbit()) (*cc)++ ; |
2661 | +} |
2662 | + |
2663 | +/************************** real*4 ************************/ |
2664 | +static float adr4buf[512] ; |
2665 | +static int adr4ibuf = 0 ; |
2666 | +static float adr4lbuf[512] ; |
2667 | +static int adr4ilbuf = -1 ; |
2668 | +static int adr4inlbuf = 0 ; |
2669 | + |
2670 | +void pushreal4(float x) { |
2671 | + addftraffic(4) ; |
2672 | + if (adr4ilbuf != -1) { |
2673 | + adr4ilbuf = -1 ; |
2674 | + adr4inlbuf = 0 ; |
2675 | + } |
2676 | + if (adr4ibuf >= 511) { |
2677 | + adr4buf[511] = x ; |
2678 | + pushNarray((char*)adr4buf, 512*4) ; |
2679 | + addftraffic(-512*4) ; |
2680 | + adr4ibuf = 0 ; |
2681 | + } else { |
2682 | + adr4buf[adr4ibuf] = x ; |
2683 | + ++adr4ibuf ; |
2684 | + } |
2685 | +} |
2686 | + |
2687 | +void lookreal4(float *x) { |
2688 | + if (adr4ilbuf == -1) { |
2689 | + adr4ilbuf = adr4ibuf ; |
2690 | + resetadlookstack_() ; |
2691 | + } |
2692 | + if (adr4ilbuf <= 0) { |
2693 | + lookNarray((char*)adr4lbuf, 512*4) ; |
2694 | + adr4inlbuf = 1 ; |
2695 | + adr4ilbuf = 511 ; |
2696 | + *x = adr4lbuf[511] ; |
2697 | + } else { |
2698 | + --adr4ilbuf ; |
2699 | + if (adr4inlbuf) |
2700 | + *x = adr4lbuf[adr4ilbuf] ; |
2701 | + else |
2702 | + *x = adr4buf[adr4ilbuf] ; |
2703 | + } |
2704 | +} |
2705 | + |
2706 | +void popreal4(float *x) { |
2707 | + if (adr4ilbuf != -1) { |
2708 | + adr4ilbuf = -1 ; |
2709 | + adr4inlbuf = 0 ; |
2710 | + } |
2711 | + if (adr4ibuf <= 0) { |
2712 | + popNarray((char*)adr4buf, 512*4) ; |
2713 | + adr4ibuf = 511 ; |
2714 | + *x = adr4buf[511] ; |
2715 | + } else { |
2716 | + --adr4ibuf ; |
2717 | + *x = adr4buf[adr4ibuf] ; |
2718 | + } |
2719 | +} |
2720 | + |
2721 | +/************************** real*8 ************************/ |
2722 | +static double adr8buf[512] ; |
2723 | +static int adr8ibuf = 0 ; |
2724 | +static double adr8lbuf[512] ; |
2725 | +static int adr8ilbuf = -1 ; |
2726 | +static int adr8inlbuf = 0 ; |
2727 | + |
2728 | +void pushreal8(double x) { |
2729 | + addftraffic(8) ; |
2730 | + if (adr8ilbuf != -1) { |
2731 | + adr8ilbuf = -1 ; |
2732 | + adr8inlbuf = 0 ; |
2733 | + } |
2734 | + if (adr8ibuf >= 511) { |
2735 | + adr8buf[511] = x ; |
2736 | + pushNarray((char*)adr8buf, 512*8) ; |
2737 | + addftraffic(-4096) ; |
2738 | + adr8ibuf = 0 ; |
2739 | + } else { |
2740 | + adr8buf[adr8ibuf] = x ; |
2741 | + ++adr8ibuf ; |
2742 | + } |
2743 | +} |
2744 | + |
2745 | +void lookreal8(double *x) { |
2746 | + if (adr8ilbuf == -1) { |
2747 | + adr8ilbuf = adr8ibuf ; |
2748 | + resetadlookstack_() ; |
2749 | + } |
2750 | + if (adr8ilbuf <= 0) { |
2751 | + lookNarray((char*)adr8lbuf, 512*8) ; |
2752 | + adr8inlbuf = 1 ; |
2753 | + adr8ilbuf = 511 ; |
2754 | + *x = adr8lbuf[511] ; |
2755 | + } else { |
2756 | + --adr8ilbuf ; |
2757 | + if (adr8inlbuf) |
2758 | + *x = adr8lbuf[adr8ilbuf] ; |
2759 | + else |
2760 | + *x = adr8buf[adr8ilbuf] ; |
2761 | + } |
2762 | +} |
2763 | + |
2764 | +void popreal8(double *x) { |
2765 | + if (adr8ilbuf != -1) { |
2766 | + adr8ilbuf = -1 ; |
2767 | + adr8inlbuf = 0 ; |
2768 | + } |
2769 | + if (adr8ibuf <= 0) { |
2770 | + popNarray((char*)adr8buf, 512*8) ; |
2771 | + adr8ibuf = 511 ; |
2772 | + *x = adr8buf[511] ; |
2773 | + } else { |
2774 | + --adr8ibuf ; |
2775 | + *x = adr8buf[adr8ibuf] ; |
2776 | + } |
2777 | +} |
2778 | + |
2779 | +/********* PRINTING THE SIZE OF STACKS AND BUFFERS ********/ |
2780 | + |
2781 | +void printbuffertop() { |
2782 | + int size = 0 ; |
2783 | + size += adi4ibuf*4 ; |
2784 | + size += adr4ibuf*4 ; |
2785 | + size += adr8ibuf*8 ; |
2786 | + printf("Buffer size:%i bytes i.e. %i Kbytes\n", |
2787 | + size, (int) (size/1024.0)) ; |
2788 | +} |
2789 | + |
2790 | +void showallstacks() { |
2791 | + int i ; |
2792 | + printf("BIT STACK : %x == %i\n",adbitbuf,adbitbuf) ; |
2793 | + printf("INTEGER*4 BUFFER[%i]:",adi4ibuf) ; |
2794 | + for (i=0 ; i<adi4ibuf ; ++i) printf(" %i",adi4buf[i]) ; |
2795 | + printf("\n") ; |
2796 | + printf("REAL*8 BUFFER[%i]:",adr8ibuf) ; |
2797 | + for (i=0 ; i<adr8ibuf ; ++i) printf(" %d",(int) adr8buf[i]) ; |
2798 | + printf("\n") ; |
2799 | + printf("REAL*4 BUFFER[%i]:",adr4ibuf) ; |
2800 | + for (i=0 ; i<adr4ibuf ; ++i) printf(" %f",adr4buf[i]) ; |
2801 | + printf("\n") ; |
2802 | + showrecentcstack_() ; |
2803 | +} |
2804 | + |
2805 | +/********************************************************** |
2806 | + * HOW TO CREATE PUSH* LOOK* POP* SUBROUTINES |
2807 | + * YET FOR OTHER DATA TYPES |
2808 | + * Duplicate and uncomment the commented code below. |
2809 | + * In the duplicated code, replace: |
2810 | + * ctct -> C type name (e.g. float double, int...) |
2811 | + * TTTT -> BASIC TAPENADE TYPE NAME |
2812 | + * (in character, boolean, integer, real, complex, pointer,...) |
2813 | + * z7 -> LETTER-SIZE FOR TYPE |
2814 | + * (in s, b, i, r, c, p, ...) |
2815 | + * 7 -> TYPE SIZE IN BYTES |
2816 | + * Don't forget to insert the corresponding lines in |
2817 | + * procedure printbuffertop(), otherwise the contribution of |
2818 | + * this new type to buffer occupation will not be seen. |
2819 | + * (not very important anyway...) |
2820 | + **********************************************************/ |
2821 | + |
2822 | +/************************** TTTT*7 ************************/ |
2823 | +/* |
2824 | +static ctct adz7buf[512] ; |
2825 | +static int adz7ibuf = 0 ; |
2826 | +static ctct adz7lbuf[512] ; |
2827 | +static int adz7ilbuf = -1 ; |
2828 | +static int adz7inlbuf = 0 ; |
2829 | + |
2830 | +void pushTTTT7(ctct x) { |
2831 | + addftraffic(7) ; |
2832 | + if (adz7ilbuf != -1) { |
2833 | + adz7ilbuf = -1 ; |
2834 | + adz7inlbuf = 0 ; |
2835 | + } |
2836 | + if (adz7ibuf >= 511) { |
2837 | + adz7buf[511] = x ; |
2838 | + pushNarray((char*)adz7buf, 512*7) ; |
2839 | + addftraffic(-512*7) ; |
2840 | + adz7ibuf = 0 ; |
2841 | + } else { |
2842 | + adz7buf[adz7ibuf] = x ; |
2843 | + ++adz7ibuf ; |
2844 | + } |
2845 | +} |
2846 | + |
2847 | +void lookTTTT7(ctct *x) { |
2848 | + if (adz7ilbuf == -1) { |
2849 | + adz7ilbuf = adz7ibuf ; |
2850 | + resetadlookstack_() ; |
2851 | + } |
2852 | + if (adz7ilbuf <= 0) { |
2853 | + lookNarray((char*)adz7lbuf, 512*7) ; |
2854 | + adz7inlbuf = 1 ; |
2855 | + adz7ilbuf = 511 ; |
2856 | + *x = adz7lbuf[511] ; |
2857 | + } else { |
2858 | + --adz7ilbuf ; |
2859 | + if (adz7inlbuf) |
2860 | + *x = adz7lbuf[adz7ilbuf] ; |
2861 | + else |
2862 | + *x = adz7buf[adz7ilbuf] ; |
2863 | + } |
2864 | +} |
2865 | + |
2866 | +void popTTTT7(ctct *x) { |
2867 | + if (adz7ilbuf != -1) { |
2868 | + adz7ilbuf = -1 ; |
2869 | + adz7inlbuf = 0 ; |
2870 | + } |
2871 | + if (adz7ibuf <= 0) { |
2872 | + popNarray((char*)adz7buf, 512*7) ; |
2873 | + adz7ibuf = 511 ; |
2874 | + *x = adz7buf[511] ; |
2875 | + } else { |
2876 | + --adz7ibuf ; |
2877 | + *x = adz7buf[adz7ibuf] ; |
2878 | + } |
2879 | +} |
2880 | +*/ |
2881 | + |
2882 | +/**********************************************************/ |
2883 | |
2884 | === added file 'adjoint/adBufferFortran.f' |
2885 | --- adjoint/adBufferFortran.f 1970-01-01 00:00:00 +0000 |
2886 | +++ adjoint/adBufferFortran.f 2011-07-12 15:56:32 +0000 |
2887 | @@ -0,0 +1,1848 @@ |
2888 | +C$Id: adBuffer.f 3922 2011-05-19 08:54:39Z llh $ |
2889 | + |
2890 | +c PISTES D'AMELIORATIONS: |
2891 | +c Attention aux IF qui peuvent couter cher. |
2892 | +c On pourrait aussi bufferiser les bits avec N entiers, |
2893 | +c (1 bit par entier), passer tout le paquet a C et laisser |
2894 | +c C faire les jongleries de bitsets. |
2895 | +c On pourrait aussi optimiser en -O3 les primitives de ADFirstAidKit |
2896 | +c Regarder l'assembleur (option -S (et -o toto.s)) |
2897 | +c Pourchasser les divisions! |
2898 | + |
2899 | + BLOCK DATA LOOKINGORNOT |
2900 | + LOGICAL looking |
2901 | + COMMON /lookingfbuf/looking |
2902 | + DATA looking/.FALSE./ |
2903 | + END |
2904 | + |
2905 | +c======================== BITS ==========================: |
2906 | + BLOCK DATA BITS |
2907 | + INTEGER*4 adbitbuf, adbitlbuf |
2908 | + INTEGER adbitibuf, adbitilbuf |
2909 | + LOGICAL adbitinlbuf |
2910 | + COMMON /adbitfbuf/adbitbuf,adbitlbuf, |
2911 | + + adbitibuf,adbitilbuf,adbitinlbuf |
2912 | + DATA adbitbuf/0/ |
2913 | + DATA adbitlbuf/0/ |
2914 | + DATA adbitibuf/0/ |
2915 | + DATA adbitilbuf/-1/ |
2916 | + DATA adbitinlbuf/.FALSE./ |
2917 | + END |
2918 | + |
2919 | +c [0,31] are the bit indices we can use in an INTEGER |
2920 | + |
2921 | + SUBROUTINE PUSHBIT(bit) |
2922 | + LOGICAL bit |
2923 | + INTEGER*4 adbitbuf, adbitlbuf |
2924 | + INTEGER adbitibuf, adbitilbuf |
2925 | + LOGICAL adbitinlbuf |
2926 | + COMMON /adbitfbuf/adbitbuf,adbitlbuf, |
2927 | + + adbitibuf,adbitilbuf,adbitinlbuf |
2928 | + LOGICAL looking |
2929 | + COMMON /lookingfbuf/looking |
2930 | +c |
2931 | + IF (adbitilbuf.ne.-1) THEN |
2932 | + adbitilbuf = -1 |
2933 | + adbitinlbuf = .FALSE. |
2934 | + looking = .FALSE. |
2935 | + ENDIF |
2936 | + IF (bit) THEN |
2937 | + adbitbuf = IBSET(adbitbuf, adbitibuf) |
2938 | + ELSE |
2939 | + adbitbuf = IBCLR(adbitbuf, adbitibuf) |
2940 | + ENDIF |
2941 | + IF (adbitibuf.ge.31) THEN |
2942 | + CALL PUSHINTEGER4(adbitbuf) |
2943 | + adbitbuf = 0 |
2944 | + adbitibuf = 0 |
2945 | + ELSE |
2946 | + adbitibuf = adbitibuf+1 |
2947 | + ENDIF |
2948 | + END |
2949 | + |
2950 | + LOGICAL FUNCTION LOOKBIT() |
2951 | + INTEGER*4 adbitbuf, adbitlbuf |
2952 | + INTEGER adbitibuf, adbitilbuf |
2953 | + LOGICAL adbitinlbuf |
2954 | + COMMON /adbitfbuf/adbitbuf,adbitlbuf, |
2955 | + + adbitibuf,adbitilbuf,adbitinlbuf |
2956 | + LOGICAL looking |
2957 | + COMMON /lookingfbuf/looking |
2958 | +c |
2959 | + IF (adbitilbuf.eq.-1) THEN |
2960 | + adbitilbuf=adbitibuf |
2961 | + adbitlbuf = adbitbuf |
2962 | + IF (.not.looking) THEN |
2963 | + CALL RESETADLOOKSTACK() |
2964 | + looking = .TRUE. |
2965 | + ENDIF |
2966 | + ENDIF |
2967 | + IF (adbitilbuf.le.0) THEN |
2968 | + CALL LOOKINTEGER4(adbitlbuf) |
2969 | + adbitilbuf = 31 |
2970 | + ELSE |
2971 | + adbitilbuf = adbitilbuf-1 |
2972 | + ENDIF |
2973 | + LOOKBIT = BTEST(adbitlbuf, adbitilbuf) |
2974 | + END |
2975 | + |
2976 | + LOGICAL FUNCTION POPBIT() |
2977 | + INTEGER*4 adbitbuf, adbitlbuf |
2978 | + INTEGER adbitibuf, adbitilbuf |
2979 | + LOGICAL adbitinlbuf |
2980 | + COMMON /adbitfbuf/adbitbuf,adbitlbuf, |
2981 | + + adbitibuf,adbitilbuf,adbitinlbuf |
2982 | + LOGICAL looking |
2983 | + COMMON /lookingfbuf/looking |
2984 | +c |
2985 | + IF (adbitilbuf.ne.-1) THEN |
2986 | + adbitilbuf = -1 |
2987 | + adbitinlbuf = .FALSE. |
2988 | + looking = .FALSE. |
2989 | + ENDIF |
2990 | + IF (adbitibuf.le.0) THEN |
2991 | + CALL POPINTEGER4(adbitbuf) |
2992 | + adbitibuf = 31 |
2993 | + ELSE |
2994 | + adbitibuf = adbitibuf-1 |
2995 | + ENDIF |
2996 | + POPBIT = BTEST(adbitbuf, adbitibuf) |
2997 | + END |
2998 | + |
2999 | +c====================== CONTROL =========================: |
3000 | + |
3001 | + SUBROUTINE PUSHCONTROL1B(cc) |
3002 | + INTEGER cc |
3003 | + CALL PUSHBIT(cc.ne.0) |
3004 | + END |
3005 | + |
3006 | + SUBROUTINE POPCONTROL1B(cc) |
3007 | + INTEGER cc |
3008 | + LOGICAL POPBIT |
3009 | + IF (POPBIT()) THEN |
3010 | + cc = 1 |
3011 | + ELSE |
3012 | + cc = 0 |
3013 | + ENDIF |
3014 | + END |
3015 | + |
3016 | + SUBROUTINE LOOKCONTROL1B(cc) |
3017 | + INTEGER cc |
3018 | + LOGICAL LOOKBIT |
3019 | + IF (LOOKBIT()) THEN |
3020 | + cc = 1 |
3021 | + ELSE |
3022 | + cc = 0 |
3023 | + ENDIF |
3024 | + END |
3025 | + |
3026 | + SUBROUTINE PUSHCONTROL2B(cc) |
3027 | + INTEGER cc |
3028 | + CALL PUSHBIT(BTEST(cc,0)) |
3029 | + CALL PUSHBIT(BTEST(cc,1)) |
3030 | + END |
3031 | + |
3032 | + SUBROUTINE POPCONTROL2B(cc) |
3033 | + INTEGER cc |
3034 | + LOGICAL POPBIT |
3035 | + IF (POPBIT()) THEN |
3036 | + cc = 2 |
3037 | + ELSE |
3038 | + cc = 0 |
3039 | + ENDIF |
3040 | + IF (POPBIT()) cc = IBSET(cc,0) |
3041 | + END |
3042 | + |
3043 | + SUBROUTINE LOOKCONTROL2B(cc) |
3044 | + INTEGER cc |
3045 | + LOGICAL LOOKBIT |
3046 | + IF (LOOKBIT()) THEN |
3047 | + cc = 2 |
3048 | + ELSE |
3049 | + cc = 0 |
3050 | + ENDIF |
3051 | + IF (LOOKBIT()) cc = IBSET(cc,0) |
3052 | + END |
3053 | + |
3054 | + SUBROUTINE PUSHCONTROL3B(cc) |
3055 | + INTEGER cc |
3056 | + CALL PUSHBIT(BTEST(cc,0)) |
3057 | + CALL PUSHBIT(BTEST(cc,1)) |
3058 | + CALL PUSHBIT(BTEST(cc,2)) |
3059 | + END |
3060 | + |
3061 | + SUBROUTINE POPCONTROL3B(cc) |
3062 | + INTEGER cc |
3063 | + LOGICAL POPBIT |
3064 | + IF (POPBIT()) THEN |
3065 | + cc = 4 |
3066 | + ELSE |
3067 | + cc = 0 |
3068 | + ENDIF |
3069 | + IF (POPBIT()) cc = IBSET(cc,1) |
3070 | + IF (POPBIT()) cc = IBSET(cc,0) |
3071 | + END |
3072 | + |
3073 | + SUBROUTINE LOOKCONTROL3B(cc) |
3074 | + INTEGER cc |
3075 | + LOGICAL LOOKBIT |
3076 | + IF (LOOKBIT()) THEN |
3077 | + cc = 4 |
3078 | + ELSE |
3079 | + cc = 0 |
3080 | + ENDIF |
3081 | + IF (LOOKBIT()) cc = IBSET(cc,1) |
3082 | + IF (LOOKBIT()) cc = IBSET(cc,0) |
3083 | + END |
3084 | + |
3085 | + SUBROUTINE PUSHCONTROL4B(cc) |
3086 | + INTEGER cc |
3087 | + CALL PUSHBIT(BTEST(cc,0)) |
3088 | + CALL PUSHBIT(BTEST(cc,1)) |
3089 | + CALL PUSHBIT(BTEST(cc,2)) |
3090 | + CALL PUSHBIT(BTEST(cc,3)) |
3091 | + END |
3092 | + |
3093 | + SUBROUTINE POPCONTROL4B(cc) |
3094 | + INTEGER cc |
3095 | + LOGICAL POPBIT |
3096 | + IF (POPBIT()) THEN |
3097 | + cc = 8 |
3098 | + ELSE |
3099 | + cc = 0 |
3100 | + ENDIF |
3101 | + IF (POPBIT()) cc = IBSET(cc,2) |
3102 | + IF (POPBIT()) cc = IBSET(cc,1) |
3103 | + IF (POPBIT()) cc = IBSET(cc,0) |
3104 | + END |
3105 | + |
3106 | + SUBROUTINE LOOKCONTROL4B(cc) |
3107 | + INTEGER cc |
3108 | + LOGICAL LOOKBIT |
3109 | + IF (LOOKBIT()) THEN |
3110 | + cc = 8 |
3111 | + ELSE |
3112 | + cc = 0 |
3113 | + ENDIF |
3114 | + IF (LOOKBIT()) cc = IBSET(cc,2) |
3115 | + IF (LOOKBIT()) cc = IBSET(cc,1) |
3116 | + IF (LOOKBIT()) cc = IBSET(cc,0) |
3117 | + END |
3118 | + |
3119 | + SUBROUTINE PUSHCONTROL5B(cc) |
3120 | + INTEGER cc |
3121 | + CALL PUSHBIT(BTEST(cc,0)) |
3122 | + CALL PUSHBIT(BTEST(cc,1)) |
3123 | + CALL PUSHBIT(BTEST(cc,2)) |
3124 | + CALL PUSHBIT(BTEST(cc,3)) |
3125 | + CALL PUSHBIT(BTEST(cc,4)) |
3126 | + END |
3127 | + |
3128 | + SUBROUTINE POPCONTROL5B(cc) |
3129 | + INTEGER cc |
3130 | + LOGICAL POPBIT |
3131 | + IF (POPBIT()) THEN |
3132 | + cc = 16 |
3133 | + ELSE |
3134 | + cc = 0 |
3135 | + ENDIF |
3136 | + IF (POPBIT()) cc = IBSET(cc,3) |
3137 | + IF (POPBIT()) cc = IBSET(cc,2) |
3138 | + IF (POPBIT()) cc = IBSET(cc,1) |
3139 | + IF (POPBIT()) cc = IBSET(cc,0) |
3140 | + END |
3141 | + |
3142 | + SUBROUTINE LOOKCONTROL5B(cc) |
3143 | + INTEGER cc |
3144 | + LOGICAL LOOKBIT |
3145 | + IF (LOOKBIT()) THEN |
3146 | + cc = 16 |
3147 | + ELSE |
3148 | + cc = 0 |
3149 | + ENDIF |
3150 | + IF (LOOKBIT()) cc = IBSET(cc,3) |
3151 | + IF (LOOKBIT()) cc = IBSET(cc,2) |
3152 | + IF (LOOKBIT()) cc = IBSET(cc,1) |
3153 | + IF (LOOKBIT()) cc = IBSET(cc,0) |
3154 | + END |
3155 | + |
3156 | +c======================= BOOLEANS ========================= |
3157 | + |
3158 | + SUBROUTINE PUSHBOOLEAN(x) |
3159 | + LOGICAL x |
3160 | + CALL PUSHBIT(x) |
3161 | + END |
3162 | + |
3163 | + SUBROUTINE LOOKBOOLEAN(x) |
3164 | + LOGICAL x, LOOKBIT |
3165 | + x = LOOKBIT() |
3166 | + END |
3167 | + |
3168 | + SUBROUTINE POPBOOLEAN(x) |
3169 | + LOGICAL x, POPBIT |
3170 | + x = POPBIT() |
3171 | + END |
3172 | + |
3173 | +c===================== CHARACTERS =======================: |
3174 | + BLOCK DATA CHARACTERS |
3175 | + CHARACTER ads1buf(512), ads1lbuf(512) |
3176 | + INTEGER ads1ibuf,ads1ilbuf |
3177 | + LOGICAL ads1inlbuf |
3178 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
3179 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
3180 | + DATA ads1ibuf/1/ |
3181 | + DATA ads1ilbuf/-1/ |
3182 | + DATA ads1inlbuf/.FALSE./ |
3183 | + END |
3184 | + |
3185 | + SUBROUTINE PUSHCHARACTER(x) |
3186 | + CHARACTER x, ads1buf(512), ads1lbuf(512) |
3187 | + INTEGER ads1ibuf,ads1ilbuf |
3188 | + LOGICAL ads1inlbuf |
3189 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
3190 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
3191 | + LOGICAL looking |
3192 | + COMMON /lookingfbuf/looking |
3193 | +c |
3194 | + CALL addftraffic(1) |
3195 | + IF (ads1ilbuf.ne.-1) THEN |
3196 | + ads1ilbuf = -1 |
3197 | + ads1inlbuf = .FALSE. |
3198 | + looking = .FALSE. |
3199 | + ENDIF |
3200 | + IF (ads1ibuf.ge.512) THEN |
3201 | + ads1buf(512) = x |
3202 | + CALL PUSHCHARACTERARRAY(ads1buf, 512) |
3203 | + CALL addftraffic(-512) |
3204 | + ads1ibuf = 1 |
3205 | + ELSE |
3206 | + ads1buf(ads1ibuf) = x |
3207 | + ads1ibuf = ads1ibuf+1 |
3208 | + ENDIF |
3209 | + END |
3210 | + |
3211 | + SUBROUTINE LOOKCHARACTER(x) |
3212 | + CHARACTER x, ads1buf(512), ads1lbuf(512) |
3213 | + INTEGER ads1ibuf,ads1ilbuf |
3214 | + LOGICAL ads1inlbuf |
3215 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
3216 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
3217 | + LOGICAL looking |
3218 | + COMMON /lookingfbuf/looking |
3219 | +c |
3220 | + IF (ads1ilbuf.eq.-1) THEN |
3221 | + ads1ilbuf=ads1ibuf |
3222 | + IF (.not.looking) THEN |
3223 | + CALL RESETADLOOKSTACK() |
3224 | + looking = .TRUE. |
3225 | + ENDIF |
3226 | + ENDIF |
3227 | + IF (ads1ilbuf.le.1) THEN |
3228 | + CALL LOOKCHARACTERARRAY(ads1lbuf, 512) |
3229 | + ads1inlbuf = .TRUE. |
3230 | + ads1ilbuf = 512 |
3231 | + x = ads1lbuf(512) |
3232 | + ELSE |
3233 | + ads1ilbuf = ads1ilbuf-1 |
3234 | + if (ads1inlbuf) THEN |
3235 | + x = ads1lbuf(ads1ilbuf) |
3236 | + ELSE |
3237 | + x = ads1buf(ads1ilbuf) |
3238 | + ENDIF |
3239 | + ENDIF |
3240 | + END |
3241 | + |
3242 | + SUBROUTINE POPCHARACTER(x) |
3243 | + CHARACTER x, ads1buf(512), ads1lbuf(512) |
3244 | + INTEGER ads1ibuf,ads1ilbuf |
3245 | + LOGICAL ads1inlbuf |
3246 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
3247 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
3248 | + LOGICAL looking |
3249 | + COMMON /lookingfbuf/looking |
3250 | +c |
3251 | + IF (ads1ilbuf.ne.-1) THEN |
3252 | + ads1ilbuf = -1 |
3253 | + ads1inlbuf = .FALSE. |
3254 | + looking = .FALSE. |
3255 | + ENDIF |
3256 | + IF (ads1ibuf.le.1) THEN |
3257 | + CALL POPCHARACTERARRAY(ads1buf, 512) |
3258 | + ads1ibuf = 512 |
3259 | + x = ads1buf(512) |
3260 | + ELSE |
3261 | + ads1ibuf = ads1ibuf-1 |
3262 | + x = ads1buf(ads1ibuf) |
3263 | + ENDIF |
3264 | + END |
3265 | + |
3266 | +c======================= INTEGER*4 =========================: |
3267 | + BLOCK DATA INTEGERS4 |
3268 | + INTEGER*4 adi4buf(512), adi4lbuf(512) |
3269 | + INTEGER adi4ibuf,adi4ilbuf |
3270 | + LOGICAL adi4inlbuf |
3271 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
3272 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
3273 | + DATA adi4ibuf/1/ |
3274 | + DATA adi4ilbuf/-1/ |
3275 | + DATA adi4inlbuf/.FALSE./ |
3276 | + END |
3277 | + |
3278 | + SUBROUTINE PUSHINTEGER4(x) |
3279 | + INTEGER*4 x, adi4buf(512), adi4lbuf(512) |
3280 | + INTEGER adi4ibuf,adi4ilbuf |
3281 | + LOGICAL adi4inlbuf |
3282 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
3283 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
3284 | + LOGICAL looking |
3285 | + COMMON /lookingfbuf/looking |
3286 | +c |
3287 | + CALL addftraffic(4) |
3288 | + IF (adi4ilbuf.ne.-1) THEN |
3289 | + adi4ilbuf = -1 |
3290 | + adi4inlbuf = .FALSE. |
3291 | + looking = .FALSE. |
3292 | + ENDIF |
3293 | + IF (adi4ibuf.ge.512) THEN |
3294 | + adi4buf(512) = x |
3295 | + CALL PUSHINTEGER4ARRAY(adi4buf, 512) |
3296 | + CALL addftraffic(-2048) |
3297 | + adi4ibuf = 1 |
3298 | + ELSE |
3299 | + adi4buf(adi4ibuf) = x |
3300 | + adi4ibuf = adi4ibuf+1 |
3301 | + ENDIF |
3302 | + END |
3303 | + |
3304 | + SUBROUTINE LOOKINTEGER4(x) |
3305 | + INTEGER*4 x, adi4buf(512), adi4lbuf(512) |
3306 | + INTEGER adi4ibuf,adi4ilbuf |
3307 | + LOGICAL adi4inlbuf |
3308 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
3309 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
3310 | + LOGICAL looking |
3311 | + COMMON /lookingfbuf/looking |
3312 | +c |
3313 | + IF (adi4ilbuf.eq.-1) THEN |
3314 | + adi4ilbuf=adi4ibuf |
3315 | + IF (.not.looking) THEN |
3316 | + CALL RESETADLOOKSTACK() |
3317 | + looking = .TRUE. |
3318 | + ENDIF |
3319 | + ENDIF |
3320 | + IF (adi4ilbuf.le.1) THEN |
3321 | + CALL LOOKINTEGER4ARRAY(adi4lbuf, 512) |
3322 | + adi4inlbuf = .TRUE. |
3323 | + adi4ilbuf = 512 |
3324 | + x = adi4lbuf(512) |
3325 | + ELSE |
3326 | + adi4ilbuf = adi4ilbuf-1 |
3327 | + if (adi4inlbuf) THEN |
3328 | + x = adi4lbuf(adi4ilbuf) |
3329 | + ELSE |
3330 | + x = adi4buf(adi4ilbuf) |
3331 | + ENDIF |
3332 | + ENDIF |
3333 | + END |
3334 | + |
3335 | + SUBROUTINE POPINTEGER4(x) |
3336 | + INTEGER*4 x, adi4buf(512), adi4lbuf(512) |
3337 | + INTEGER adi4ibuf,adi4ilbuf |
3338 | + LOGICAL adi4inlbuf |
3339 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
3340 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
3341 | + LOGICAL looking |
3342 | + COMMON /lookingfbuf/looking |
3343 | +c |
3344 | + IF (adi4ilbuf.ne.-1) THEN |
3345 | + adi4ilbuf = -1 |
3346 | + adi4inlbuf = .FALSE. |
3347 | + looking = .FALSE. |
3348 | + ENDIF |
3349 | + IF (adi4ibuf.le.1) THEN |
3350 | + CALL POPINTEGER4ARRAY(adi4buf, 512) |
3351 | + adi4ibuf = 512 |
3352 | + x = adi4buf(512) |
3353 | + ELSE |
3354 | + adi4ibuf = adi4ibuf-1 |
3355 | + x = adi4buf(adi4ibuf) |
3356 | + ENDIF |
3357 | + END |
3358 | + |
3359 | +c======================= INTEGER*8 ========================= |
3360 | + BLOCK DATA INTEGERS8 |
3361 | + INTEGER*8 adi8buf(512), adi8lbuf(512) |
3362 | + INTEGER adi8ibuf,adi8ilbuf |
3363 | + LOGICAL adi8inlbuf |
3364 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
3365 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
3366 | + DATA adi8ibuf/1/ |
3367 | + DATA adi8ilbuf/-1/ |
3368 | + DATA adi8inlbuf/.FALSE./ |
3369 | + END |
3370 | + |
3371 | + SUBROUTINE PUSHINTEGER8(x) |
3372 | + INTEGER*8 x, adi8buf(512), adi8lbuf(512) |
3373 | + INTEGER adi8ibuf,adi8ilbuf |
3374 | + LOGICAL adi8inlbuf |
3375 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
3376 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
3377 | + LOGICAL looking |
3378 | + COMMON /lookingfbuf/looking |
3379 | +c |
3380 | + CALL addftraffic(8) |
3381 | + IF (adi8ilbuf.ne.-1) THEN |
3382 | + adi8ilbuf = -1 |
3383 | + adi8inlbuf = .FALSE. |
3384 | + looking = .FALSE. |
3385 | + ENDIF |
3386 | + IF (adi8ibuf.ge.512) THEN |
3387 | + adi8buf(512) = x |
3388 | + CALL PUSHINTEGER8ARRAY(adi8buf, 512) |
3389 | + CALL addftraffic(-4096) |
3390 | + adi8ibuf = 1 |
3391 | + ELSE |
3392 | + adi8buf(adi8ibuf) = x |
3393 | + adi8ibuf = adi8ibuf+1 |
3394 | + ENDIF |
3395 | + END |
3396 | + |
3397 | + SUBROUTINE LOOKINTEGER8(x) |
3398 | + INTEGER*8 x, adi8buf(512), adi8lbuf(512) |
3399 | + INTEGER adi8ibuf,adi8ilbuf |
3400 | + LOGICAL adi8inlbuf |
3401 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
3402 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
3403 | + LOGICAL looking |
3404 | + COMMON /lookingfbuf/looking |
3405 | +c |
3406 | + IF (adi8ilbuf.eq.-1) THEN |
3407 | + adi8ilbuf=adi8ibuf |
3408 | + IF (.not.looking) THEN |
3409 | + CALL RESETADLOOKSTACK() |
3410 | + looking = .TRUE. |
3411 | + ENDIF |
3412 | + ENDIF |
3413 | + IF (adi8ilbuf.le.1) THEN |
3414 | + CALL LOOKINTEGER8ARRAY(adi8lbuf, 512) |
3415 | + adi8inlbuf = .TRUE. |
3416 | + adi8ilbuf = 512 |
3417 | + x = adi8lbuf(512) |
3418 | + ELSE |
3419 | + adi8ilbuf = adi8ilbuf-1 |
3420 | + if (adi8inlbuf) THEN |
3421 | + x = adi8lbuf(adi8ilbuf) |
3422 | + ELSE |
3423 | + x = adi8buf(adi8ilbuf) |
3424 | + ENDIF |
3425 | + ENDIF |
3426 | + END |
3427 | + |
3428 | + SUBROUTINE POPINTEGER8(x) |
3429 | + INTEGER*8 x, adi8buf(512), adi8lbuf(512) |
3430 | + INTEGER adi8ibuf,adi8ilbuf |
3431 | + LOGICAL adi8inlbuf |
3432 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
3433 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
3434 | + LOGICAL looking |
3435 | + COMMON /lookingfbuf/looking |
3436 | +c |
3437 | + IF (adi8ilbuf.ne.-1) THEN |
3438 | + adi8ilbuf = -1 |
3439 | + adi8inlbuf = .FALSE. |
3440 | + looking = .FALSE. |
3441 | + ENDIF |
3442 | + IF (adi8ibuf.le.1) THEN |
3443 | + CALL POPINTEGER8ARRAY(adi8buf, 512) |
3444 | + adi8ibuf = 512 |
3445 | + x = adi8buf(512) |
3446 | + ELSE |
3447 | + adi8ibuf = adi8ibuf-1 |
3448 | + x = adi8buf(adi8ibuf) |
3449 | + ENDIF |
3450 | + END |
3451 | + |
3452 | +c======================= REAL*4 ========================= |
3453 | + BLOCK DATA REALS4 |
3454 | + REAL*4 adr4buf(512), adr4lbuf(512) |
3455 | + INTEGER adr4ibuf,adr4ilbuf |
3456 | + LOGICAL adr4inlbuf |
3457 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
3458 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
3459 | + DATA adr4ibuf/1/ |
3460 | + DATA adr4ilbuf/-1/ |
3461 | + DATA adr4inlbuf/.FALSE./ |
3462 | + END |
3463 | + |
3464 | + SUBROUTINE PUSHREAL4(x) |
3465 | + REAL*4 x, adr4buf(512), adr4lbuf(512) |
3466 | + INTEGER adr4ibuf,adr4ilbuf |
3467 | + LOGICAL adr4inlbuf |
3468 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
3469 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
3470 | + LOGICAL looking |
3471 | + COMMON /lookingfbuf/looking |
3472 | +c |
3473 | + CALL addftraffic(4) |
3474 | + IF (adr4ilbuf.ne.-1) THEN |
3475 | + adr4ilbuf = -1 |
3476 | + adr4inlbuf = .FALSE. |
3477 | + looking = .FALSE. |
3478 | + ENDIF |
3479 | + IF (adr4ibuf.ge.512) THEN |
3480 | + adr4buf(512) = x |
3481 | + CALL PUSHREAL4ARRAY(adr4buf, 512) |
3482 | + CALL addftraffic(-2048) |
3483 | + adr4ibuf = 1 |
3484 | + ELSE |
3485 | + adr4buf(adr4ibuf) = x |
3486 | + adr4ibuf = adr4ibuf+1 |
3487 | + ENDIF |
3488 | + END |
3489 | + |
3490 | + SUBROUTINE LOOKREAL4(x) |
3491 | + REAL*4 x, adr4buf(512), adr4lbuf(512) |
3492 | + INTEGER adr4ibuf,adr4ilbuf |
3493 | + LOGICAL adr4inlbuf |
3494 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
3495 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
3496 | + LOGICAL looking |
3497 | + COMMON /lookingfbuf/looking |
3498 | +c |
3499 | + IF (adr4ilbuf.eq.-1) THEN |
3500 | + adr4ilbuf=adr4ibuf |
3501 | + IF (.not.looking) THEN |
3502 | + CALL RESETADLOOKSTACK() |
3503 | + looking = .TRUE. |
3504 | + ENDIF |
3505 | + ENDIF |
3506 | + IF (adr4ilbuf.le.1) THEN |
3507 | + CALL LOOKREAL4ARRAY(adr4lbuf, 512) |
3508 | + adr4inlbuf = .TRUE. |
3509 | + adr4ilbuf = 512 |
3510 | + x = adr4lbuf(512) |
3511 | + ELSE |
3512 | + adr4ilbuf = adr4ilbuf-1 |
3513 | + if (adr4inlbuf) THEN |
3514 | + x = adr4lbuf(adr4ilbuf) |
3515 | + ELSE |
3516 | + x = adr4buf(adr4ilbuf) |
3517 | + ENDIF |
3518 | + ENDIF |
3519 | + END |
3520 | + |
3521 | + SUBROUTINE POPREAL4(x) |
3522 | + REAL*4 x, adr4buf(512), adr4lbuf(512) |
3523 | + INTEGER adr4ibuf,adr4ilbuf |
3524 | + LOGICAL adr4inlbuf |
3525 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
3526 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
3527 | + LOGICAL looking |
3528 | + COMMON /lookingfbuf/looking |
3529 | +c |
3530 | + IF (adr4ilbuf.ne.-1) THEN |
3531 | + adr4ilbuf = -1 |
3532 | + adr4inlbuf = .FALSE. |
3533 | + looking = .FALSE. |
3534 | + ENDIF |
3535 | + IF (adr4ibuf.le.1) THEN |
3536 | + CALL POPREAL4ARRAY(adr4buf, 512) |
3537 | + adr4ibuf = 512 |
3538 | + x = adr4buf(512) |
3539 | + ELSE |
3540 | + adr4ibuf = adr4ibuf-1 |
3541 | + x = adr4buf(adr4ibuf) |
3542 | + ENDIF |
3543 | + END |
3544 | + |
3545 | +c======================= REAL*8 ========================= |
3546 | + BLOCK DATA REALS8 |
3547 | + REAL*8 adr8buf(512), adr8lbuf(512) |
3548 | + INTEGER adr8ibuf,adr8ilbuf |
3549 | + LOGICAL adr8inlbuf |
3550 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
3551 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
3552 | + DATA adr8ibuf/1/ |
3553 | + DATA adr8ilbuf/-1/ |
3554 | + DATA adr8inlbuf/.FALSE./ |
3555 | + END |
3556 | + |
3557 | + SUBROUTINE PUSHREAL8(x) |
3558 | + REAL*8 x, adr8buf(512), adr8lbuf(512) |
3559 | + INTEGER adr8ibuf,adr8ilbuf |
3560 | + LOGICAL adr8inlbuf |
3561 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
3562 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
3563 | + LOGICAL looking |
3564 | + COMMON /lookingfbuf/looking |
3565 | +c |
3566 | + CALL addftraffic(8) |
3567 | + IF (adr8ilbuf.ne.-1) THEN |
3568 | + adr8ilbuf = -1 |
3569 | + adr8inlbuf = .FALSE. |
3570 | + looking = .FALSE. |
3571 | + ENDIF |
3572 | + IF (adr8ibuf.ge.512) THEN |
3573 | + adr8buf(512) = x |
3574 | + CALL PUSHREAL8ARRAY(adr8buf, 512) |
3575 | + CALL addftraffic(-4096) |
3576 | + adr8ibuf = 1 |
3577 | + ELSE |
3578 | + adr8buf(adr8ibuf) = x |
3579 | + adr8ibuf = adr8ibuf+1 |
3580 | + ENDIF |
3581 | + END |
3582 | + |
3583 | + SUBROUTINE LOOKREAL8(x) |
3584 | + REAL*8 x, adr8buf(512), adr8lbuf(512) |
3585 | + INTEGER adr8ibuf,adr8ilbuf |
3586 | + LOGICAL adr8inlbuf |
3587 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
3588 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
3589 | + LOGICAL looking |
3590 | + COMMON /lookingfbuf/looking |
3591 | +c |
3592 | + IF (adr8ilbuf.eq.-1) THEN |
3593 | + adr8ilbuf=adr8ibuf |
3594 | + IF (.not.looking) THEN |
3595 | + CALL RESETADLOOKSTACK() |
3596 | + looking = .TRUE. |
3597 | + ENDIF |
3598 | + ENDIF |
3599 | + IF (adr8ilbuf.le.1) THEN |
3600 | + CALL LOOKREAL8ARRAY(adr8lbuf, 512) |
3601 | + adr8inlbuf = .TRUE. |
3602 | + adr8ilbuf = 512 |
3603 | + x = adr8lbuf(512) |
3604 | + ELSE |
3605 | + adr8ilbuf = adr8ilbuf-1 |
3606 | + if (adr8inlbuf) THEN |
3607 | + x = adr8lbuf(adr8ilbuf) |
3608 | + ELSE |
3609 | + x = adr8buf(adr8ilbuf) |
3610 | + ENDIF |
3611 | + ENDIF |
3612 | + END |
3613 | + |
3614 | + SUBROUTINE POPREAL8(x) |
3615 | + REAL*8 x, adr8buf(512), adr8lbuf(512) |
3616 | + INTEGER adr8ibuf,adr8ilbuf |
3617 | + LOGICAL adr8inlbuf |
3618 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
3619 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
3620 | + LOGICAL looking |
3621 | + COMMON /lookingfbuf/looking |
3622 | +c |
3623 | + IF (adr8ilbuf.ne.-1) THEN |
3624 | + adr8ilbuf = -1 |
3625 | + adr8inlbuf = .FALSE. |
3626 | + looking = .FALSE. |
3627 | + ENDIF |
3628 | + IF (adr8ibuf.le.1) THEN |
3629 | + CALL POPREAL8ARRAY(adr8buf, 512) |
3630 | + adr8ibuf = 512 |
3631 | + x = adr8buf(512) |
3632 | + ELSE |
3633 | + adr8ibuf = adr8ibuf-1 |
3634 | + x = adr8buf(adr8ibuf) |
3635 | + ENDIF |
3636 | + END |
3637 | + |
3638 | +c======================= REAL*16 ========================= |
3639 | + BLOCK DATA REALS16 |
3640 | + DOUBLE PRECISION adr16buf(512), adr16lbuf(512) |
3641 | + INTEGER adr16ibuf,adr16ilbuf |
3642 | + LOGICAL adr16inlbuf |
3643 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
3644 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
3645 | + DATA adr16ibuf/1/ |
3646 | + DATA adr16ilbuf/-1/ |
3647 | + DATA adr16inlbuf/.FALSE./ |
3648 | + END |
3649 | + |
3650 | + SUBROUTINE PUSHREAL16(x) |
3651 | + DOUBLE PRECISION x, adr16buf(512), adr16lbuf(512) |
3652 | + INTEGER adr16ibuf,adr16ilbuf |
3653 | + LOGICAL adr16inlbuf |
3654 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
3655 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
3656 | + LOGICAL looking |
3657 | + COMMON /lookingfbuf/looking |
3658 | +c |
3659 | + CALL addftraffic(16) |
3660 | + IF (adr16ilbuf.ne.-1) THEN |
3661 | + adr16ilbuf = -1 |
3662 | + adr16inlbuf = .FALSE. |
3663 | + looking = .FALSE. |
3664 | + ENDIF |
3665 | + IF (adr16ibuf.ge.512) THEN |
3666 | + adr16buf(512) = x |
3667 | + CALL PUSHREAL16ARRAY(adr16buf, 512) |
3668 | + CALL addftraffic(-8192) |
3669 | + adr16ibuf = 1 |
3670 | + ELSE |
3671 | + adr16buf(adr16ibuf) = x |
3672 | + adr16ibuf = adr16ibuf+1 |
3673 | + ENDIF |
3674 | + END |
3675 | + |
3676 | + SUBROUTINE LOOKREAL16(x) |
3677 | + DOUBLE PRECISION x, adr16buf(512), adr16lbuf(512) |
3678 | + INTEGER adr16ibuf,adr16ilbuf |
3679 | + LOGICAL adr16inlbuf |
3680 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
3681 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
3682 | + LOGICAL looking |
3683 | + COMMON /lookingfbuf/looking |
3684 | +c |
3685 | + IF (adr16ilbuf.eq.-1) THEN |
3686 | + adr16ilbuf=adr16ibuf |
3687 | + IF (.not.looking) THEN |
3688 | + CALL RESETADLOOKSTACK() |
3689 | + looking = .TRUE. |
3690 | + ENDIF |
3691 | + ENDIF |
3692 | + IF (adr16ilbuf.le.1) THEN |
3693 | + CALL LOOKREAL16ARRAY(adr16lbuf, 512) |
3694 | + adr16inlbuf = .TRUE. |
3695 | + adr16ilbuf = 512 |
3696 | + x = adr16lbuf(512) |
3697 | + ELSE |
3698 | + adr16ilbuf = adr16ilbuf-1 |
3699 | + if (adr16inlbuf) THEN |
3700 | + x = adr16lbuf(adr16ilbuf) |
3701 | + ELSE |
3702 | + x = adr16buf(adr16ilbuf) |
3703 | + ENDIF |
3704 | + ENDIF |
3705 | + END |
3706 | + |
3707 | + SUBROUTINE POPREAL16(x) |
3708 | + DOUBLE PRECISION x, adr16buf(512), adr16lbuf(512) |
3709 | + INTEGER adr16ibuf,adr16ilbuf |
3710 | + LOGICAL adr16inlbuf |
3711 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
3712 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
3713 | + LOGICAL looking |
3714 | + COMMON /lookingfbuf/looking |
3715 | +c |
3716 | + IF (adr16ilbuf.ne.-1) THEN |
3717 | + adr16ilbuf = -1 |
3718 | + adr16inlbuf = .FALSE. |
3719 | + looking = .FALSE. |
3720 | + ENDIF |
3721 | + IF (adr16ibuf.le.1) THEN |
3722 | + CALL POPREAL16ARRAY(adr16buf, 512) |
3723 | + adr16ibuf = 512 |
3724 | + x = adr16buf(512) |
3725 | + ELSE |
3726 | + adr16ibuf = adr16ibuf-1 |
3727 | + x = adr16buf(adr16ibuf) |
3728 | + ENDIF |
3729 | + END |
3730 | + |
3731 | +c======================= COMPLEX*8 ========================= |
3732 | + BLOCK DATA COMPLEXS8 |
3733 | + COMPLEX*8 adc8buf(512), adc8lbuf(512) |
3734 | + INTEGER adc8ibuf,adc8ilbuf |
3735 | + LOGICAL adc8inlbuf |
3736 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
3737 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
3738 | + DATA adc8ibuf/1/ |
3739 | + DATA adc8ilbuf/-1/ |
3740 | + DATA adc8inlbuf/.FALSE./ |
3741 | + END |
3742 | + |
3743 | + SUBROUTINE PUSHCOMPLEX8(x) |
3744 | + COMPLEX*8 x, adc8buf(512), adc8lbuf(512) |
3745 | + INTEGER adc8ibuf,adc8ilbuf |
3746 | + LOGICAL adc8inlbuf |
3747 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
3748 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
3749 | + LOGICAL looking |
3750 | + COMMON /lookingfbuf/looking |
3751 | +c |
3752 | + CALL addftraffic(8) |
3753 | + IF (adc8ilbuf.ne.-1) THEN |
3754 | + adc8ilbuf = -1 |
3755 | + adc8inlbuf = .FALSE. |
3756 | + looking = .FALSE. |
3757 | + ENDIF |
3758 | + IF (adc8ibuf.ge.512) THEN |
3759 | + adc8buf(512) = x |
3760 | + CALL PUSHCOMPLEX8ARRAY(adc8buf, 512) |
3761 | + CALL addftraffic(-4096) |
3762 | + adc8ibuf = 1 |
3763 | + ELSE |
3764 | + adc8buf(adc8ibuf) = x |
3765 | + adc8ibuf = adc8ibuf+1 |
3766 | + ENDIF |
3767 | + END |
3768 | + |
3769 | + SUBROUTINE LOOKCOMPLEX8(x) |
3770 | + COMPLEX*8 x, adc8buf(512), adc8lbuf(512) |
3771 | + INTEGER adc8ibuf,adc8ilbuf |
3772 | + LOGICAL adc8inlbuf |
3773 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
3774 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
3775 | + LOGICAL looking |
3776 | + COMMON /lookingfbuf/looking |
3777 | +c |
3778 | + IF (adc8ilbuf.eq.-1) THEN |
3779 | + adc8ilbuf=adc8ibuf |
3780 | + IF (.not.looking) THEN |
3781 | + CALL RESETADLOOKSTACK() |
3782 | + looking = .TRUE. |
3783 | + ENDIF |
3784 | + ENDIF |
3785 | + IF (adc8ilbuf.le.1) THEN |
3786 | + CALL LOOKCOMPLEX8ARRAY(adc8lbuf, 512) |
3787 | + adc8inlbuf = .TRUE. |
3788 | + adc8ilbuf = 512 |
3789 | + x = adc8lbuf(512) |
3790 | + ELSE |
3791 | + adc8ilbuf = adc8ilbuf-1 |
3792 | + if (adc8inlbuf) THEN |
3793 | + x = adc8lbuf(adc8ilbuf) |
3794 | + ELSE |
3795 | + x = adc8buf(adc8ilbuf) |
3796 | + ENDIF |
3797 | + ENDIF |
3798 | + END |
3799 | + |
3800 | + SUBROUTINE POPCOMPLEX8(x) |
3801 | + COMPLEX*8 x, adc8buf(512), adc8lbuf(512) |
3802 | + INTEGER adc8ibuf,adc8ilbuf |
3803 | + LOGICAL adc8inlbuf |
3804 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
3805 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
3806 | + LOGICAL looking |
3807 | + COMMON /lookingfbuf/looking |
3808 | +c |
3809 | + IF (adc8ilbuf.ne.-1) THEN |
3810 | + adc8ilbuf = -1 |
3811 | + adc8inlbuf = .FALSE. |
3812 | + looking = .FALSE. |
3813 | + ENDIF |
3814 | + IF (adc8ibuf.le.1) THEN |
3815 | + CALL POPCOMPLEX8ARRAY(adc8buf, 512) |
3816 | + adc8ibuf = 512 |
3817 | + x = adc8buf(512) |
3818 | + ELSE |
3819 | + adc8ibuf = adc8ibuf-1 |
3820 | + x = adc8buf(adc8ibuf) |
3821 | + ENDIF |
3822 | + END |
3823 | + |
3824 | +c======================= COMPLEX*16 ========================= |
3825 | + BLOCK DATA COMPLEXS16 |
3826 | + COMPLEX*16 adc16buf(512), adc16lbuf(512) |
3827 | + INTEGER adc16ibuf,adc16ilbuf |
3828 | + LOGICAL adc16inlbuf |
3829 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
3830 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
3831 | + DATA adc16ibuf/1/ |
3832 | + DATA adc16ilbuf/-1/ |
3833 | + DATA adc16inlbuf/.FALSE./ |
3834 | + END |
3835 | + |
3836 | + SUBROUTINE PUSHCOMPLEX16(x) |
3837 | + COMPLEX*16 x, adc16buf(512), adc16lbuf(512) |
3838 | + INTEGER adc16ibuf,adc16ilbuf |
3839 | + LOGICAL adc16inlbuf |
3840 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
3841 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
3842 | + LOGICAL looking |
3843 | + COMMON /lookingfbuf/looking |
3844 | +c |
3845 | + CALL addftraffic(16) |
3846 | + IF (adc16ilbuf.ne.-1) THEN |
3847 | + adc16ilbuf = -1 |
3848 | + adc16inlbuf = .FALSE. |
3849 | + looking = .FALSE. |
3850 | + ENDIF |
3851 | + IF (adc16ibuf.ge.512) THEN |
3852 | + adc16buf(512) = x |
3853 | + CALL PUSHCOMPLEX16ARRAY(adc16buf, 512) |
3854 | + CALL addftraffic(-8192) |
3855 | + adc16ibuf = 1 |
3856 | + ELSE |
3857 | + adc16buf(adc16ibuf) = x |
3858 | + adc16ibuf = adc16ibuf+1 |
3859 | + ENDIF |
3860 | + END |
3861 | + |
3862 | + SUBROUTINE LOOKCOMPLEX16(x) |
3863 | + COMPLEX*16 x, adc16buf(512), adc16lbuf(512) |
3864 | + INTEGER adc16ibuf,adc16ilbuf |
3865 | + LOGICAL adc16inlbuf |
3866 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
3867 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
3868 | + LOGICAL looking |
3869 | + COMMON /lookingfbuf/looking |
3870 | +c |
3871 | + IF (adc16ilbuf.eq.-1) THEN |
3872 | + adc16ilbuf=adc16ibuf |
3873 | + IF (.not.looking) THEN |
3874 | + CALL RESETADLOOKSTACK() |
3875 | + looking = .TRUE. |
3876 | + ENDIF |
3877 | + ENDIF |
3878 | + IF (adc16ilbuf.le.1) THEN |
3879 | + CALL LOOKCOMPLEX16ARRAY(adc16lbuf, 512) |
3880 | + adc16inlbuf = .TRUE. |
3881 | + adc16ilbuf = 512 |
3882 | + x = adc16lbuf(512) |
3883 | + ELSE |
3884 | + adc16ilbuf = adc16ilbuf-1 |
3885 | + if (adc16inlbuf) THEN |
3886 | + x = adc16lbuf(adc16ilbuf) |
3887 | + ELSE |
3888 | + x = adc16buf(adc16ilbuf) |
3889 | + ENDIF |
3890 | + ENDIF |
3891 | + END |
3892 | + |
3893 | + SUBROUTINE POPCOMPLEX16(x) |
3894 | + COMPLEX*16 x, adc16buf(512), adc16lbuf(512) |
3895 | + INTEGER adc16ibuf,adc16ilbuf |
3896 | + LOGICAL adc16inlbuf |
3897 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
3898 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
3899 | + LOGICAL looking |
3900 | + COMMON /lookingfbuf/looking |
3901 | +c |
3902 | + IF (adc16ilbuf.ne.-1) THEN |
3903 | + adc16ilbuf = -1 |
3904 | + adc16inlbuf = .FALSE. |
3905 | + looking = .FALSE. |
3906 | + ENDIF |
3907 | + IF (adc16ibuf.le.1) THEN |
3908 | + CALL POPCOMPLEX16ARRAY(adc16buf, 512) |
3909 | + adc16ibuf = 512 |
3910 | + x = adc16buf(512) |
3911 | + ELSE |
3912 | + adc16ibuf = adc16ibuf-1 |
3913 | + x = adc16buf(adc16ibuf) |
3914 | + ENDIF |
3915 | + END |
3916 | + |
3917 | +C=========== MEASUREMENT OF PUSH/POP TRAFFIC ========== |
3918 | + |
3919 | + BLOCK DATA MEMTRAFFIC |
3920 | + INTEGER*8 mmftraffic,mmftrafficM |
3921 | + COMMON /mmcomtraffic/mmftraffic,mmftrafficM |
3922 | + DATA mmftraffic/0/ |
3923 | + DATA mmftrafficM/0/ |
3924 | + END |
3925 | + |
3926 | + subroutine addftraffic(n) |
3927 | + INTEGER n |
3928 | + INTEGER*8 mmftraffic,mmftrafficM |
3929 | + COMMON /mmcomtraffic/mmftraffic,mmftrafficM |
3930 | +c |
3931 | + mmftraffic = mmftraffic+n |
3932 | + if (mmftraffic.ge.1000000) then |
3933 | + 100 mmftraffic = mmftraffic-1000000 |
3934 | + mmftrafficM = mmftrafficM+1 |
3935 | + if (mmftraffic.ge.1000000) then |
3936 | + goto 100 |
3937 | + else |
3938 | + goto 300 |
3939 | + endif |
3940 | + else if (mmftraffic.lt.0) then |
3941 | + 200 mmftraffic = mmftraffic+1000000 |
3942 | + mmftrafficM = mmftrafficM-1 |
3943 | + if (mmftraffic.lt.0) then |
3944 | + goto 200 |
3945 | + else |
3946 | + goto 300 |
3947 | + endif |
3948 | + endif |
3949 | + 300 continue |
3950 | + END |
3951 | + |
3952 | + SUBROUTINE PRINTTRAFFIC() |
3953 | + INTEGER*8 mmftraffic,mmftrafficM |
3954 | + COMMON /mmcomtraffic/mmftraffic,mmftrafficM |
3955 | + CALL printctraffic() |
3956 | + CALL printftrafficinc(mmftrafficM, 1000000, mmftraffic) |
3957 | +c write (6,1001) ' F Traffic: ',mmftrafficM,' Mb and ', |
3958 | +c + (((mmftraffic*1000)/1024)*1000)/1024, ' millionths' |
3959 | +c 1001 format(a,i6,a,i6,a) |
3960 | + END |
3961 | + |
3962 | +C ============ PRINTING THE SIZE OF STACKS AND BUFFERS ========== |
3963 | + |
3964 | + SUBROUTINE PRINTBUFFERTOP() |
3965 | + integer*4 SMALLSTACKSIZE |
3966 | + integer*4 size |
3967 | + |
3968 | + size = SMALLSTACKSIZE() |
3969 | + print *,'Buffer size:',size,' bytes i.e. ',size/1024.0,' Kbytes' |
3970 | + END |
3971 | + |
3972 | + FUNCTION SMALLSTACKSIZE() |
3973 | + CHARACTER ads1buf(512), ads1lbuf(512) |
3974 | + INTEGER ads1ibuf,ads1ilbuf |
3975 | + LOGICAL ads1inlbuf |
3976 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
3977 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
3978 | +c LOGICAL adl4buf(512), adl4lbuf(512) |
3979 | +c INTEGER adl4ibuf,adl4ilbuf |
3980 | +c LOGICAL adl4inlbuf |
3981 | +c COMMON /adl4fbuf/adl4buf,adl4lbuf, |
3982 | +c + adl4ibuf,adl4ilbuf,adl4inlbuf |
3983 | + INTEGER*4 adi4buf(512), adi4lbuf(512) |
3984 | + INTEGER adi4ibuf,adi4ilbuf |
3985 | + LOGICAL adi4inlbuf |
3986 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
3987 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
3988 | + INTEGER*8 adi8buf(512), adi8lbuf(512) |
3989 | + INTEGER adi8ibuf,adi8ilbuf |
3990 | + LOGICAL adi8inlbuf |
3991 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
3992 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
3993 | +c INTEGER*16 adi16buf(512), adi16lbuf(512) |
3994 | +c INTEGER adi16ibuf,adi16ilbuf |
3995 | +c LOGICAL adi16inlbuf |
3996 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
3997 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
3998 | + REAL*4 adr4buf(512), adr4lbuf(512) |
3999 | + INTEGER adr4ibuf,adr4ilbuf |
4000 | + LOGICAL adr4inlbuf |
4001 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
4002 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
4003 | + REAL*8 adr8buf(512), adr8lbuf(512) |
4004 | + INTEGER adr8ibuf,adr8ilbuf |
4005 | + LOGICAL adr8inlbuf |
4006 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
4007 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
4008 | + DOUBLE PRECISION adr16buf(512), adr16lbuf(512) |
4009 | + INTEGER adr16ibuf,adr16ilbuf |
4010 | + LOGICAL adr16inlbuf |
4011 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
4012 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
4013 | +c REAL*32 x, adr32buf(512), adr32lbuf(512) |
4014 | +c INTEGER adr32ibuf,adr32ilbuf |
4015 | +c LOGICAL adr32inlbuf |
4016 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4017 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4018 | +c COMPLEX*4 adc4buf(512), adc4lbuf(512) |
4019 | +c INTEGER adc4ibuf,adc4ilbuf |
4020 | +c LOGICAL adc4inlbuf |
4021 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4022 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4023 | + COMPLEX*8 adc8buf(512), adc8lbuf(512) |
4024 | + INTEGER adc8ibuf,adc8ilbuf |
4025 | + LOGICAL adc8inlbuf |
4026 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
4027 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
4028 | + COMPLEX*16 adc16buf(512), adc16lbuf(512) |
4029 | + INTEGER adc16ibuf,adc16ilbuf |
4030 | + LOGICAL adc16inlbuf |
4031 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
4032 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
4033 | +c COMPLEX*32 adc32buf(512), adc32lbuf(512) |
4034 | +c INTEGER adc32ibuf,adc32ilbuf |
4035 | +c LOGICAL adc32inlbuf |
4036 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4037 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4038 | + integer*4 smallstacksize |
4039 | +c |
4040 | + smallstacksize = 0 |
4041 | + smallstacksize = smallstacksize + (ads1ibuf-1)*1 |
4042 | +c smallstacksize = smallstacksize + (adl4ibuf-1)*4 |
4043 | + smallstacksize = smallstacksize + (adi4ibuf-1)*4 |
4044 | + smallstacksize = smallstacksize + (adi8ibuf-1)*8 |
4045 | +c smallstacksize = smallstacksize + (adi16ibuf-1)*16 |
4046 | + smallstacksize = smallstacksize + (adr4ibuf-1)*4 |
4047 | + smallstacksize = smallstacksize + (adr8ibuf-1)*8 |
4048 | + smallstacksize = smallstacksize + (adr16ibuf-1)*16 |
4049 | +c smallstacksize = smallstacksize + (adr32ibuf-1)*32 |
4050 | +c smallstacksize = smallstacksize + (adc4ibuf-1)*4 |
4051 | + smallstacksize = smallstacksize + (adc8ibuf-1)*8 |
4052 | + smallstacksize = smallstacksize + (adc16ibuf-1)*16 |
4053 | +c smallstacksize = smallstacksize + (adc32ibuf-1)*32 |
4054 | +c |
4055 | + end |
4056 | + |
4057 | +c Very complete display of the current size of the |
4058 | +c push/look/pop local Fortran stacks and global C stack. |
4059 | + SUBROUTINE PRINTALLBUFFERS() |
4060 | + CHARACTER ads1buf(512), ads1lbuf(512) |
4061 | + INTEGER ads1ibuf,ads1ilbuf |
4062 | + LOGICAL ads1inlbuf |
4063 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
4064 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
4065 | +c LOGICAL adl4buf(512), adl4lbuf(512) |
4066 | +c INTEGER adl4ibuf,adl4ilbuf |
4067 | +c LOGICAL adl4inlbuf |
4068 | +c COMMON /adl4fbuf/adl4buf,adl4lbuf, |
4069 | +c + adl4ibuf,adl4ilbuf,adl4inlbuf |
4070 | + INTEGER*4 adi4buf(512), adi4lbuf(512) |
4071 | + INTEGER adi4ibuf,adi4ilbuf |
4072 | + LOGICAL adi4inlbuf |
4073 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
4074 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
4075 | + INTEGER*8 adi8buf(512), adi8lbuf(512) |
4076 | + INTEGER adi8ibuf,adi8ilbuf |
4077 | + LOGICAL adi8inlbuf |
4078 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
4079 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
4080 | +c INTEGER*16 adi16buf(512), adi16lbuf(512) |
4081 | +c INTEGER adi16ibuf,adi16ilbuf |
4082 | +c LOGICAL adi16inlbuf |
4083 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
4084 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
4085 | + REAL*4 adr4buf(512), adr4lbuf(512) |
4086 | + INTEGER adr4ibuf,adr4ilbuf |
4087 | + LOGICAL adr4inlbuf |
4088 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
4089 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
4090 | + REAL*8 adr8buf(512), adr8lbuf(512) |
4091 | + INTEGER adr8ibuf,adr8ilbuf |
4092 | + LOGICAL adr8inlbuf |
4093 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
4094 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
4095 | + DOUBLE PRECISION adr16buf(512), adr16lbuf(512) |
4096 | + INTEGER adr16ibuf,adr16ilbuf |
4097 | + LOGICAL adr16inlbuf |
4098 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
4099 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
4100 | +c REAL*32 x, adr32buf(512), adr32lbuf(512) |
4101 | +c INTEGER adr32ibuf,adr32ilbuf |
4102 | +c LOGICAL adr32inlbuf |
4103 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4104 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4105 | +c COMPLEX*4 adc4buf(512), adc4lbuf(512) |
4106 | +c INTEGER adc4ibuf,adc4ilbuf |
4107 | +c LOGICAL adc4inlbuf |
4108 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4109 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4110 | + COMPLEX*8 adc8buf(512), adc8lbuf(512) |
4111 | + INTEGER adc8ibuf,adc8ilbuf |
4112 | + LOGICAL adc8inlbuf |
4113 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
4114 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
4115 | + COMPLEX*16 adc16buf(512), adc16lbuf(512) |
4116 | + INTEGER adc16ibuf,adc16ilbuf |
4117 | + LOGICAL adc16inlbuf |
4118 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
4119 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
4120 | +c COMPLEX*32 adc32buf(512), adc32lbuf(512) |
4121 | +c INTEGER adc32ibuf,adc32ilbuf |
4122 | +c LOGICAL adc32inlbuf |
4123 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4124 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4125 | + integer*4 bsize,lookbsize |
4126 | + integer*4 cblocks, csize, lookcblocks, lookcsize |
4127 | +c |
4128 | + call getbigcsizes(cblocks,csize,lookcblocks,lookcsize) |
4129 | + write (6,'(a,i8,a,i5,a,i8,a,i5,a)') |
4130 | + + 'MAIN stack size (in C) :',cblocks,'B +',csize, |
4131 | + + ' (looking:',lookcblocks,'B +',lookcsize,')' |
4132 | + bsize = (ads1ibuf-1)*1 |
4133 | + lookbsize = -999 |
4134 | + if (ads1inlbuf.or.ads1ilbuf.gt.-1) lookbsize=(ads1ilbuf-1)*1 |
4135 | + write (6,'(a,i4,a,i4,a)') 'CHARs :',bsize, |
4136 | + + ' (looking:',lookbsize,')' |
4137 | +c bsize = (adl4ibuf-1)*4 |
4138 | + bsize = (adi4ibuf-1)*4 |
4139 | + lookbsize = -999 |
4140 | + if (adi4inlbuf.or.adi4ilbuf.gt.-1) lookbsize=(adi4ilbuf-1)*4 |
4141 | + write (6,'(a,i4,a,i4,a)') 'INTs4 :',bsize, |
4142 | + + ' (looking:',lookbsize,')' |
4143 | + bsize = (adi8ibuf-1)*8 |
4144 | + lookbsize = -999 |
4145 | + if (adi8inlbuf.or.adi8ilbuf.gt.-1) lookbsize=(adi8ilbuf-1)*8 |
4146 | + write (6,'(a,i4,a,i4,a)') 'INTs8 :',bsize, |
4147 | + + ' (looking:',lookbsize,')' |
4148 | +c bsize = (adi16ibuf-1)*16 |
4149 | + bsize = (adr4ibuf-1)*4 |
4150 | + lookbsize = -999 |
4151 | + if (adr4inlbuf.or.adr4ilbuf.gt.-1) lookbsize=(adr4ilbuf-1)*4 |
4152 | + write (6,'(a,i4,a,i4,a)') 'REALs4 :',bsize, |
4153 | + + ' (looking:',lookbsize,')' |
4154 | + bsize = (adr8ibuf-1)*8 |
4155 | + lookbsize = -999 |
4156 | + if (adr8inlbuf.or.adr8ilbuf.gt.-1) lookbsize=(adr8ilbuf-1)*8 |
4157 | + write (6,'(a,i4,a,i4,a)') 'REALs8 :',bsize, |
4158 | + + ' (looking:',lookbsize,')' |
4159 | + bsize = (adr16ibuf-1)*16 |
4160 | + lookbsize = -999 |
4161 | + if (adr16inlbuf.or.adr16ilbuf.gt.-1) lookbsize=(adr16ilbuf-1)*16 |
4162 | + write (6,'(a,i4,a,i4,a)') 'REALs16:',bsize, |
4163 | + + ' (looking:',lookbsize,')' |
4164 | +c bsize = (adr32ibuf-1)*32 |
4165 | +c bsize = (adc4ibuf-1)*4 |
4166 | + bsize = (adc8ibuf-1)*8 |
4167 | + lookbsize = -999 |
4168 | + if (adc8inlbuf.or.adc8ilbuf.gt.-1) lookbsize=(adc8ilbuf-1)*8 |
4169 | + write (6,'(a,i4,a,i4,a)') 'CPLXs8 :',bsize, |
4170 | + + ' (looking:',lookbsize,')' |
4171 | + bsize = (adc16ibuf-1)*16 |
4172 | + lookbsize = -999 |
4173 | + if (adc16inlbuf.or.adc16ilbuf.gt.-1) lookbsize=(adc16ilbuf-1)*16 |
4174 | + write (6,'(a,i4,a,i4,a)') 'CPLXs16:',bsize, |
4175 | + + ' (looking:',lookbsize,')' |
4176 | +c bsize = (adc32ibuf-1)*32 |
4177 | +c |
4178 | + end |
4179 | + |
4180 | +C FOR INTERNAL DEBUGS ONLY: |
4181 | + SUBROUTINE SHOWALLSTACKS() |
4182 | + INTEGER*4 adbitbuf, adbitlbuf |
4183 | + INTEGER adbitibuf, adbitilbuf |
4184 | + LOGICAL adbitinlbuf |
4185 | + COMMON /adbitfbuf/adbitbuf,adbitlbuf, |
4186 | + + adbitibuf,adbitilbuf,adbitinlbuf |
4187 | + CHARACTER ads1buf(512), ads1lbuf(512) |
4188 | + INTEGER ads1ibuf,ads1ilbuf |
4189 | + LOGICAL ads1inlbuf |
4190 | + COMMON /ads1fbuf/ads1buf,ads1lbuf, |
4191 | + + ads1ibuf,ads1ilbuf,ads1inlbuf |
4192 | + INTEGER*4 adi4buf(512), adi4lbuf(512) |
4193 | + INTEGER adi4ibuf,adi4ilbuf |
4194 | + LOGICAL adi4inlbuf |
4195 | + COMMON /adi4fbuf/adi4buf,adi4lbuf, |
4196 | + + adi4ibuf,adi4ilbuf,adi4inlbuf |
4197 | + INTEGER*8 adi8buf(512), adi8lbuf(512) |
4198 | + INTEGER adi8ibuf,adi8ilbuf |
4199 | + LOGICAL adi8inlbuf |
4200 | + COMMON /adi8fbuf/adi8buf,adi8lbuf, |
4201 | + + adi8ibuf,adi8ilbuf,adi8inlbuf |
4202 | + REAL*4 adr4buf(512), adr4lbuf(512) |
4203 | + INTEGER adr4ibuf,adr4ilbuf |
4204 | + LOGICAL adr4inlbuf |
4205 | + COMMON /adr4fbuf/adr4buf,adr4lbuf, |
4206 | + + adr4ibuf,adr4ilbuf,adr4inlbuf |
4207 | + REAL*8 adr8buf(512), adr8lbuf(512) |
4208 | + INTEGER adr8ibuf,adr8ilbuf |
4209 | + LOGICAL adr8inlbuf |
4210 | + COMMON /adr8fbuf/adr8buf,adr8lbuf, |
4211 | + + adr8ibuf,adr8ilbuf,adr8inlbuf |
4212 | + DOUBLE PRECISION adr16buf(512), adr16lbuf(512) |
4213 | + INTEGER adr16ibuf,adr16ilbuf |
4214 | + LOGICAL adr16inlbuf |
4215 | + COMMON /adr16fbuf/adr16buf,adr16lbuf, |
4216 | + + adr16ibuf,adr16ilbuf,adr16inlbuf |
4217 | + COMPLEX*8 adc8buf(512), adc8lbuf(512) |
4218 | + INTEGER adc8ibuf,adc8ilbuf |
4219 | + LOGICAL adc8inlbuf |
4220 | + COMMON /adc8fbuf/adc8buf,adc8lbuf, |
4221 | + + adc8ibuf,adc8ilbuf,adc8inlbuf |
4222 | + COMPLEX*16 adc16buf(512), adc16lbuf(512) |
4223 | + INTEGER adc16ibuf,adc16ilbuf |
4224 | + LOGICAL adc16inlbuf |
4225 | + COMMON /adc16fbuf/adc16buf,adc16lbuf, |
4226 | + + adc16ibuf,adc16ilbuf,adc16inlbuf |
4227 | + INTEGER i |
4228 | +c |
4229 | + write (6,1010) 'BIT STACK : ',adbitbuf,'==',adbitbuf, |
4230 | + + ' (',adbitibuf,')' |
4231 | +1010 format(a,i20,a,z16,a,i2,a) |
4232 | + write (6,1011) 'INTEGER*8 BUFFER[',adi8ibuf-1,']: ', |
4233 | + + (adi8buf(i),i=1,adi8ibuf-1) |
4234 | + write (6,1011) 'INTEGER*4 BUFFER[',adi4ibuf-1,']: ', |
4235 | + + (adi4buf(i),i=1,adi4ibuf-1) |
4236 | +1011 format(a,i3,a,512(i40)) |
4237 | + write (6,1012) 'REAL*16 BUFFER:[',adr16ibuf-1,']: ', |
4238 | + + (adr16buf(i),i=1,adr16ibuf-1) |
4239 | + write (6,1012) 'REAL*8 BUFFER:[',adr8ibuf-1, ']: ', |
4240 | + + (adr8buf(i),i=1,adr8ibuf-1) |
4241 | + write (6,1012) 'REAL*4 BUFFER:[',adr4ibuf-1, ']: ', |
4242 | + + (adr4buf(i),i=1,adr4ibuf-1) |
4243 | +1012 format(a,i3,a,512(e8.2)) |
4244 | + call showrecentcstack() |
4245 | +c |
4246 | + END |
4247 | + |
4248 | +C======================================================== |
4249 | +C PUSH* POP* SUBROUTINES FOR OTHER DATA TYPES |
4250 | +C Uncomment if these types are available on your compiler |
4251 | +C and they are needed by the reverse differentiated code |
4252 | +C Don't forget to uncomment the corresponding lines in |
4253 | +C subroutine PRINTBUFFERTOP, otherwise these types' |
4254 | +C contribution to buffer occupation will not be seen. |
4255 | +C (not very important anyway...) |
4256 | + |
4257 | +c======================= INTEGER*16 ========================= |
4258 | +c BLOCK DATA INTEGERS16 |
4259 | +c INTEGER*16 adi16buf(512), adi16lbuf(512) |
4260 | +c INTEGER adi16ibuf,adi16ilbuf |
4261 | +c LOGICAL adi16inlbuf |
4262 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
4263 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
4264 | +c DATA adi16ibuf/1/ |
4265 | +c DATA adi16ilbuf/-1/ |
4266 | +c DATA adi16inlbuf/.FALSE./ |
4267 | +c END |
4268 | +c c |
4269 | +c SUBROUTINE PUSHINTEGER16(x) |
4270 | +c INTEGER*16 x, adi16buf(512), adi16lbuf(512) |
4271 | +c INTEGER adi16ibuf,adi16ilbuf |
4272 | +c LOGICAL adi16inlbuf |
4273 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
4274 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
4275 | +c LOGICAL looking |
4276 | +c COMMON /lookingfbuf/looking |
4277 | +c c |
4278 | +c CALL addftraffic(16) |
4279 | +c IF (adi16ilbuf.ne.-1) THEN |
4280 | +c adi16ilbuf = -1 |
4281 | +c adi16inlbuf = .FALSE. |
4282 | +c looking = .FALSE. |
4283 | +c ENDIF |
4284 | +c IF (adi16ibuf.ge.512) THEN |
4285 | +c adi16buf(512) = x |
4286 | +c CALL PUSHINTEGER16ARRAY(adi16buf, 512) |
4287 | +c CALL addftraffic(-8192) |
4288 | +c adi16ibuf = 1 |
4289 | +c ELSE |
4290 | +c adi16buf(adi16ibuf) = x |
4291 | +c adi16ibuf = adi16ibuf+1 |
4292 | +c ENDIF |
4293 | +c END |
4294 | +c |
4295 | +c SUBROUTINE LOOKINTEGER16(x) |
4296 | +c INTEGER*16 x, adi16buf(512), adi16lbuf(512) |
4297 | +c INTEGER adi16ibuf,adi16ilbuf |
4298 | +c LOGICAL adi16inlbuf |
4299 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
4300 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
4301 | +c LOGICAL looking |
4302 | +c COMMON /lookingfbuf/looking |
4303 | +c c |
4304 | +c IF (adi16ilbuf.eq.-1) THEN |
4305 | +c adi16ilbuf=adi16ibuf |
4306 | +c IF (.not.looking) THEN |
4307 | +c CALL RESETADLOOKSTACK() |
4308 | +c looking = .TRUE. |
4309 | +c ENDIF |
4310 | +c ENDIF |
4311 | +c IF (adi16ilbuf.le.1) THEN |
4312 | +c CALL LOOKINTEGER16ARRAY(adi16lbuf, 512) |
4313 | +c adi16inlbuf = .TRUE. |
4314 | +c adi16ilbuf = 512 |
4315 | +c x = adi16lbuf(512) |
4316 | +c ELSE |
4317 | +c adi16ilbuf = adi16ilbuf-1 |
4318 | +c if (adi16inlbuf) THEN |
4319 | +c x = adi16lbuf(adi16ilbuf) |
4320 | +c ELSE |
4321 | +c x = adi16buf(adi16ilbuf) |
4322 | +c ENDIF |
4323 | +c ENDIF |
4324 | +c END |
4325 | +c |
4326 | +c SUBROUTINE POPINTEGER16(x) |
4327 | +c INTEGER*16 x, adi16buf(512), adi16lbuf(512) |
4328 | +c INTEGER adi16ibuf,adi16ilbuf |
4329 | +c LOGICAL adi16inlbuf |
4330 | +c COMMON /adi16fbuf/adi16buf,adi16lbuf, |
4331 | +c + adi16ibuf,adi16ilbuf,adi16inlbuf |
4332 | +c LOGICAL looking |
4333 | +c COMMON /lookingfbuf/looking |
4334 | +c c |
4335 | +c IF (adi16ilbuf.ne.-1) THEN |
4336 | +c adi16ilbuf = -1 |
4337 | +c adi16inlbuf = .FALSE. |
4338 | +c looking = .FALSE. |
4339 | +c ENDIF |
4340 | +c IF (adi16ibuf.le.1) THEN |
4341 | +c CALL POPINTEGER16ARRAY(adi16buf, 512) |
4342 | +c adi16ibuf = 512 |
4343 | +c x = adi16buf(512) |
4344 | +c ELSE |
4345 | +c adi16ibuf = adi16ibuf-1 |
4346 | +c x = adi16buf(adi16ibuf) |
4347 | +c ENDIF |
4348 | +c END |
4349 | + |
4350 | +c======================= REAL*32 ========================= |
4351 | +c BLOCK DATA REALS32 |
4352 | +c REAL*32 adr32buf(512), adr32lbuf(512) |
4353 | +c INTEGER adr32ibuf,adr32ilbuf |
4354 | +c LOGICAL adr32inlbuf |
4355 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4356 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4357 | +c DATA adr32ibuf/1/ |
4358 | +c DATA adr32ilbuf/-1/ |
4359 | +c DATA adr32inlbuf/.FALSE./ |
4360 | +c END |
4361 | +c c |
4362 | +c SUBROUTINE PUSHREAL32(x) |
4363 | +c REAL*32 x, adr32buf(512), adr32lbuf(512) |
4364 | +c INTEGER adr32ibuf,adr32ilbuf |
4365 | +c LOGICAL adr32inlbuf |
4366 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4367 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4368 | +c LOGICAL looking |
4369 | +c COMMON /lookingfbuf/looking |
4370 | +c c |
4371 | +c CALL addftraffic(32) |
4372 | +c IF (adr32ilbuf.ne.-1) THEN |
4373 | +c adr32ilbuf = -1 |
4374 | +c adr32inlbuf = .FALSE. |
4375 | +c looking = .FALSE. |
4376 | +c ENDIF |
4377 | +c IF (adr32ibuf.ge.512) THEN |
4378 | +c adr32buf(512) = x |
4379 | +c CALL PUSHREAL32ARRAY(adr32buf, 512) |
4380 | +c CALL addftraffic(-16384) |
4381 | +c adr32ibuf = 1 |
4382 | +c ELSE |
4383 | +c adr32buf(adr32ibuf) = x |
4384 | +c adr32ibuf = adr32ibuf+1 |
4385 | +c ENDIF |
4386 | +c END |
4387 | +c |
4388 | +c SUBROUTINE LOOKREAL32(x) |
4389 | +c REAL*32 x, adr32buf(512), adr32lbuf(512) |
4390 | +c INTEGER adr32ibuf,adr32ilbuf |
4391 | +c LOGICAL adr32inlbuf |
4392 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4393 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4394 | +c LOGICAL looking |
4395 | +c COMMON /lookingfbuf/looking |
4396 | +c c |
4397 | +c IF (adr32ilbuf.eq.-1) THEN |
4398 | +c adr32ilbuf=adr32ibuf |
4399 | +c IF (.not.looking) THEN |
4400 | +c CALL RESETADLOOKSTACK() |
4401 | +c looking = .TRUE. |
4402 | +c ENDIF |
4403 | +c ENDIF |
4404 | +c IF (adr32ilbuf.le.1) THEN |
4405 | +c CALL LOOKREAL32ARRAY(adr32lbuf, 512) |
4406 | +c adr32inlbuf = .TRUE. |
4407 | +c adr32ilbuf = 512 |
4408 | +c x = adr32lbuf(512) |
4409 | +c ELSE |
4410 | +c adr32ilbuf = adr32ilbuf-1 |
4411 | +c if (adr32inlbuf) THEN |
4412 | +c x = adr32lbuf(adr32ilbuf) |
4413 | +c ELSE |
4414 | +c x = adr32buf(adr32ilbuf) |
4415 | +c ENDIF |
4416 | +c ENDIF |
4417 | +c END |
4418 | +c |
4419 | +c SUBROUTINE POPREAL32(x) |
4420 | +c REAL*32 x, adr32buf(512), adr32lbuf(512) |
4421 | +c INTEGER adr32ibuf,adr32ilbuf |
4422 | +c LOGICAL adr32inlbuf |
4423 | +c COMMON /adr32fbuf/adr32buf,adr32lbuf, |
4424 | +c + adr32ibuf,adr32ilbuf,adr32inlbuf |
4425 | +c LOGICAL looking |
4426 | +c COMMON /lookingfbuf/looking |
4427 | +c c |
4428 | +c IF (adr32ilbuf.ne.-1) THEN |
4429 | +c adr32ilbuf = -1 |
4430 | +c adr32inlbuf = .FALSE. |
4431 | +c looking = .FALSE. |
4432 | +c ENDIF |
4433 | +c IF (adr32ibuf.le.1) THEN |
4434 | +c CALL POPREAL32ARRAY(adr32buf, 512) |
4435 | +c adr32ibuf = 512 |
4436 | +c x = adr32buf(512) |
4437 | +c ELSE |
4438 | +c adr32ibuf = adr32ibuf-1 |
4439 | +c x = adr32buf(adr32ibuf) |
4440 | +c ENDIF |
4441 | +c END |
4442 | + |
4443 | +c======================= COMPLEX*4 ========================= |
4444 | +c BLOCK DATA COMPLEXS4 |
4445 | +c COMPLEX*4 adc4buf(512), adc4lbuf(512) |
4446 | +c INTEGER adc4ibuf,adc4ilbuf |
4447 | +c LOGICAL adc4inlbuf |
4448 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4449 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4450 | +c DATA adc4ibuf/1/ |
4451 | +c DATA adc4ilbuf/-1/ |
4452 | +c DATA adc4inlbuf/.FALSE./ |
4453 | +c END |
4454 | +c c |
4455 | +c SUBROUTINE PUSHCOMPLEX4(x) |
4456 | +c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) |
4457 | +c INTEGER adc4ibuf,adc4ilbuf |
4458 | +c LOGICAL adc4inlbuf |
4459 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4460 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4461 | +c LOGICAL looking |
4462 | +c COMMON /lookingfbuf/looking |
4463 | +c c |
4464 | +c CALL addftraffic(4) |
4465 | +c IF (adc4ilbuf.ne.-1) THEN |
4466 | +c adc4ilbuf = -1 |
4467 | +c adc4inlbuf = .FALSE. |
4468 | +c looking = .FALSE. |
4469 | +c ENDIF |
4470 | +c IF (adc4ibuf.ge.512) THEN |
4471 | +c adc4buf(512) = x |
4472 | +c CALL PUSHCOMPLEX4ARRAY(adc4buf, 512) |
4473 | +c CALL addftraffic(-2048) |
4474 | +c adc4ibuf = 1 |
4475 | +c ELSE |
4476 | +c adc4buf(adc4ibuf) = x |
4477 | +c adc4ibuf = adc4ibuf+1 |
4478 | +c ENDIF |
4479 | +c END |
4480 | +c |
4481 | +c SUBROUTINE LOOKCOMPLEX4(x) |
4482 | +c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) |
4483 | +c INTEGER adc4ibuf,adc4ilbuf |
4484 | +c LOGICAL adc4inlbuf |
4485 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4486 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4487 | +c LOGICAL looking |
4488 | +c COMMON /lookingfbuf/looking |
4489 | +c c |
4490 | +c IF (adc4ilbuf.eq.-1) THEN |
4491 | +c adc4ilbuf=adc4ibuf |
4492 | +c IF (.not.looking) THEN |
4493 | +c CALL RESETADLOOKSTACK() |
4494 | +c looking = .TRUE. |
4495 | +c ENDIF |
4496 | +c ENDIF |
4497 | +c IF (adc4ilbuf.le.1) THEN |
4498 | +c CALL LOOKCOMPLEX4ARRAY(adc4lbuf, 512) |
4499 | +c adc4inlbuf = .TRUE. |
4500 | +c adc4ilbuf = 512 |
4501 | +c x = adc4lbuf(512) |
4502 | +c ELSE |
4503 | +c adc4ilbuf = adc4ilbuf-1 |
4504 | +c if (adc4inlbuf) THEN |
4505 | +c x = adc4lbuf(adc4ilbuf) |
4506 | +c ELSE |
4507 | +c x = adc4buf(adc4ilbuf) |
4508 | +c ENDIF |
4509 | +c ENDIF |
4510 | +c END |
4511 | +c |
4512 | +c SUBROUTINE POPCOMPLEX4(x) |
4513 | +c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) |
4514 | +c INTEGER adc4ibuf,adc4ilbuf |
4515 | +c LOGICAL adc4inlbuf |
4516 | +c COMMON /adc4fbuf/adc4buf,adc4lbuf, |
4517 | +c + adc4ibuf,adc4ilbuf,adc4inlbuf |
4518 | +c LOGICAL looking |
4519 | +c COMMON /lookingfbuf/looking |
4520 | +c c |
4521 | +c IF (adc4ilbuf.ne.-1) THEN |
4522 | +c adc4ilbuf = -1 |
4523 | +c adc4inlbuf = .FALSE. |
4524 | +c looking = .FALSE. |
4525 | +c ENDIF |
4526 | +c IF (adc4ibuf.le.1) THEN |
4527 | +c CALL POPCOMPLEX4ARRAY(adc4buf, 512) |
4528 | +c adc4ibuf = 512 |
4529 | +c x = adc4buf(512) |
4530 | +c ELSE |
4531 | +c adc4ibuf = adc4ibuf-1 |
4532 | +c x = adc4buf(adc4ibuf) |
4533 | +c ENDIF |
4534 | +c END |
4535 | + |
4536 | +c======================= COMPLEX*32 ========================= |
4537 | +c BLOCK DATA COMPLEXS32 |
4538 | +c COMPLEX*32 adc32buf(512), adc32lbuf(512) |
4539 | +c INTEGER adc32ibuf,adc32ilbuf |
4540 | +c LOGICAL adc32inlbuf |
4541 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4542 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4543 | +c DATA adc32ibuf/1/ |
4544 | +c DATA adc32ilbuf/-1/ |
4545 | +c DATA adc32inlbuf/.FALSE./ |
4546 | +c END |
4547 | +c c |
4548 | +c SUBROUTINE PUSHCOMPLEX32(x) |
4549 | +c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) |
4550 | +c INTEGER adc32ibuf,adc32ilbuf |
4551 | +c LOGICAL adc32inlbuf |
4552 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4553 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4554 | +c LOGICAL looking |
4555 | +c COMMON /lookingfbuf/looking |
4556 | +c c |
4557 | +c CALL addftraffic(32) |
4558 | +c IF (adc32ilbuf.ne.-1) THEN |
4559 | +c adc32ilbuf = -1 |
4560 | +c adc32inlbuf = .FALSE. |
4561 | +c looking = .FALSE. |
4562 | +c ENDIF |
4563 | +c IF (adc32ibuf.ge.512) THEN |
4564 | +c adc32buf(512) = x |
4565 | +c CALL PUSHCOMPLEX32ARRAY(adc32buf, 512) |
4566 | +c CALL addftraffic(-16384) |
4567 | +c adc32ibuf = 1 |
4568 | +c ELSE |
4569 | +c adc32buf(adc32ibuf) = x |
4570 | +c adc32ibuf = adc32ibuf+1 |
4571 | +c ENDIF |
4572 | +c END |
4573 | +c |
4574 | +c SUBROUTINE LOOKCOMPLEX32(x) |
4575 | +c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) |
4576 | +c INTEGER adc32ibuf,adc32ilbuf |
4577 | +c LOGICAL adc32inlbuf |
4578 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4579 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4580 | +c LOGICAL looking |
4581 | +c COMMON /lookingfbuf/looking |
4582 | +c c |
4583 | +c IF (adc32ilbuf.eq.-1) THEN |
4584 | +c adc32ilbuf=adc32ibuf |
4585 | +c IF (.not.looking) THEN |
4586 | +c CALL RESETADLOOKSTACK() |
4587 | +c looking = .TRUE. |
4588 | +c ENDIF |
4589 | +c ENDIF |
4590 | +c IF (adc32ilbuf.le.1) THEN |
4591 | +c CALL LOOKCOMPLEX32ARRAY(adc32lbuf, 512) |
4592 | +c adc32inlbuf = .TRUE. |
4593 | +c adc32ilbuf = 512 |
4594 | +c x = adc32lbuf(512) |
4595 | +c ELSE |
4596 | +c adc32ilbuf = adc32ilbuf-1 |
4597 | +c if (adc32inlbuf) THEN |
4598 | +c x = adc32lbuf(adc32ilbuf) |
4599 | +c ELSE |
4600 | +c x = adc32buf(adc32ilbuf) |
4601 | +c ENDIF |
4602 | +c ENDIF |
4603 | +c END |
4604 | +c |
4605 | +c SUBROUTINE POPCOMPLEX32(x) |
4606 | +c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) |
4607 | +c INTEGER adc32ibuf,adc32ilbuf |
4608 | +c LOGICAL adc32inlbuf |
4609 | +c COMMON /adc32fbuf/adc32buf,adc32lbuf, |
4610 | +c + adc32ibuf,adc32ilbuf,adc32inlbuf |
4611 | +c LOGICAL looking |
4612 | +c COMMON /lookingfbuf/looking |
4613 | +c c |
4614 | +c IF (adc32ilbuf.ne.-1) THEN |
4615 | +c adc32ilbuf = -1 |
4616 | +c adc32inlbuf = .FALSE. |
4617 | +c looking = .FALSE. |
4618 | +c ENDIF |
4619 | +c IF (adc32ibuf.le.1) THEN |
4620 | +c CALL POPCOMPLEX32ARRAY(adc32buf, 512) |
4621 | +c adc32ibuf = 512 |
4622 | +c x = adc32buf(512) |
4623 | +c ELSE |
4624 | +c adc32ibuf = adc32ibuf-1 |
4625 | +c x = adc32buf(adc32ibuf) |
4626 | +c ENDIF |
4627 | +c END |
4628 | + |
4629 | +C======================================================== |
4630 | +C HOW TO CREATE PUSH* POP* SUBROUTINES |
4631 | +C YET FOR OTHER DATA TYPES |
4632 | +C ** Duplicate the commented program lines below |
4633 | +c ** In the duplicated subroutines, replace: |
4634 | +c TTTT by the basic name of the type |
4635 | +c z9 by the initial and size of the type |
4636 | +c (integer:i real:r complex:c boolean:b character:s) |
4637 | +c 9 by the size of the type |
4638 | +c ** Uncomment the duplicated subroutines |
4639 | +C ** Don't forget to insert the corresponding lines in |
4640 | +C subroutine PRINTBUFFERTOP, otherwise these types' |
4641 | +C contribution to buffer occupation will not be seen. |
4642 | +C (not very important anyway...) |
4643 | + |
4644 | +c======================= TTTT*9 ========================= |
4645 | +c BLOCK DATA TTTTS9 |
4646 | +c TTTT*9 adz9buf(512), adz9lbuf(512) |
4647 | +c INTEGER adz9ibuf,adz9ilbuf |
4648 | +c LOGICAL adz9inlbuf |
4649 | +c COMMON /adz9fbuf/adz9buf,adz9lbuf, |
4650 | +c + adz9ibuf,adz9ilbuf,adz9inlbuf |
4651 | +c DATA adz9ibuf/1/ |
4652 | +c DATA adz9ilbuf/-1/ |
4653 | +c DATA adz9inlbuf/.FALSE./ |
4654 | +c END |
4655 | +c c |
4656 | +c SUBROUTINE PUSHTTTT9(x) |
4657 | +c TTTT*9 x, adz9buf(512), adz9lbuf(512) |
4658 | +c INTEGER adz9ibuf,adz9ilbuf |
4659 | +c LOGICAL adz9inlbuf |
4660 | +c COMMON /adz9fbuf/adz9buf,adz9lbuf, |
4661 | +c + adz9ibuf,adz9ilbuf,adz9inlbuf |
4662 | +c LOGICAL looking |
4663 | +c COMMON /lookingfbuf/looking |
4664 | +c c |
4665 | +c CALL addftraffic(9) |
4666 | +c IF (adz9ilbuf.ne.-1) THEN |
4667 | +c adz9ilbuf = -1 |
4668 | +c adz9inlbuf = .FALSE. |
4669 | +c looking = .FALSE. |
4670 | +c ENDIF |
4671 | +c IF (adz9ibuf.ge.512) THEN |
4672 | +c adz9buf(512) = x |
4673 | +c CALL PUSHTTTT9ARRAY(adz9buf, 512) |
4674 | +c CALL addftraffic(-9*512) |
4675 | +c adz9ibuf = 1 |
4676 | +c ELSE |
4677 | +c adz9buf(adz9ibuf) = x |
4678 | +c adz9ibuf = adz9ibuf+1 |
4679 | +c ENDIF |
4680 | +c END |
4681 | +c |
4682 | +c SUBROUTINE LOOKTTTT9(x) |
4683 | +c TTTT*9 x, adz9buf(512), adz9lbuf(512) |
4684 | +c INTEGER adz9ibuf,adz9ilbuf |
4685 | +c LOGICAL adz9inlbuf |
4686 | +c COMMON /adz9fbuf/adz9buf,adz9lbuf, |
4687 | +c + adz9ibuf,adz9ilbuf,adz9inlbuf |
4688 | +c LOGICAL looking |
4689 | +c COMMON /lookingfbuf/looking |
4690 | +c c |
4691 | +c IF (adz9ilbuf.eq.-1) THEN |
4692 | +c adz9ilbuf=adz9ibuf |
4693 | +c IF (.not.looking) THEN |
4694 | +c CALL RESETADLOOKSTACK() |
4695 | +c looking = .TRUE. |
4696 | +c ENDIF |
4697 | +c ENDIF |
4698 | +c IF (adz9ilbuf.le.1) THEN |
4699 | +c CALL LOOKTTTT9ARRAY(adz9lbuf, 512) |
4700 | +c adz9inlbuf = .TRUE. |
4701 | +c adz9ilbuf = 512 |
4702 | +c x = adz9lbuf(512) |
4703 | +c ELSE |
4704 | +c adz9ilbuf = adz9ilbuf-1 |
4705 | +c if (adz9inlbuf) THEN |
4706 | +c x = adz9lbuf(adz9ilbuf) |
4707 | +c ELSE |
4708 | +c x = adz9buf(adz9ilbuf) |
4709 | +c ENDIF |
4710 | +c ENDIF |
4711 | +c END |
4712 | +c |
4713 | +c SUBROUTINE POPTTTT9(x) |
4714 | +c TTTT*9 x, adz9buf(512), adz9lbuf(512) |
4715 | +c INTEGER adz9ibuf,adz9ilbuf |
4716 | +c LOGICAL adz9inlbuf |
4717 | +c COMMON /adz9fbuf/adz9buf,adz9lbuf, |
4718 | +c + adz9ibuf,adz9ilbuf,adz9inlbuf |
4719 | +c LOGICAL looking |
4720 | +c COMMON /lookingfbuf/looking |
4721 | +c c |
4722 | +c IF (adz9ilbuf.ne.-1) THEN |
4723 | +c adz9ilbuf = -1 |
4724 | +c adz9inlbuf = .FALSE. |
4725 | +c looking = .FALSE. |
4726 | +c ENDIF |
4727 | +c IF (adz9ibuf.le.1) THEN |
4728 | +c CALL POPTTTT9ARRAY(adz9buf, 512) |
4729 | +c adz9ibuf = 512 |
4730 | +c x = adz9buf(512) |
4731 | +c ELSE |
4732 | +c adz9ibuf = adz9ibuf-1 |
4733 | +c x = adz9buf(adz9ibuf) |
4734 | +c ENDIF |
4735 | +c END |
4736 | |
4737 | === added file 'adjoint/adStack.c' |
4738 | --- adjoint/adStack.c 1970-01-01 00:00:00 +0000 |
4739 | +++ adjoint/adStack.c 2011-07-12 15:56:32 +0000 |
4740 | @@ -0,0 +1,683 @@ |
4741 | +static char adSid[]="$Id: adStack.c 3919 2011-05-18 15:51:18Z llh $"; |
4742 | + |
4743 | +#include <stdlib.h> |
4744 | +#include <stdio.h> |
4745 | +#include <string.h> |
4746 | + |
4747 | +#define ONE_BLOCK_SIZE 16384 |
4748 | +#ifndef STACK_SIZE_TRACING |
4749 | +#define STACK_SIZE_TRACING 1 |
4750 | +#endif |
4751 | +/* The main stack is a double-chain of DoubleChainedBlock objects. |
4752 | + * Each DoubleChainedBlock holds an array[ONE_BLOCK_SIZE] of char. */ |
4753 | +typedef struct _doubleChainedBlock{ |
4754 | + struct _doubleChainedBlock *prev ; |
4755 | + char *contents ; |
4756 | + struct _doubleChainedBlock *next ; |
4757 | +} DoubleChainedBlock ; |
4758 | + |
4759 | +/* Globals that define the current position in the stack: */ |
4760 | +static DoubleChainedBlock *curStack = NULL ; |
4761 | +static char *curStackTop = NULL ; |
4762 | +/* Globals that define the current LOOKing position in the stack: */ |
4763 | +static DoubleChainedBlock *lookStack = NULL ; |
4764 | +static char *lookStackTop = NULL ; |
4765 | + |
4766 | +static long int mmctraffic = 0 ; |
4767 | +static long int mmctrafficM = 0 ; |
4768 | +#ifdef STACK_SIZE_TRACING |
4769 | +long int bigStackSize = 0; |
4770 | +#endif |
4771 | + |
4772 | +/* PUSHes "nbChars" consecutive chars from a location starting at address "x". |
4773 | + * Resets the LOOKing position if it was active. |
4774 | + * Checks that there is enough space left to hold "nbChars" chars. |
4775 | + * Otherwise, allocates the necessary space. */ |
4776 | +void pushNarray(char *x, unsigned int nbChars) { |
4777 | + unsigned int nbmax = (curStack)?ONE_BLOCK_SIZE-(curStackTop-(curStack->contents)):0 ; |
4778 | +#ifdef STACK_SIZE_TRACING |
4779 | + bigStackSize += nbChars; |
4780 | +#endif |
4781 | + |
4782 | + mmctraffic += nbChars ; |
4783 | + while (mmctraffic >= 1000000) { |
4784 | + mmctraffic -= 1000000 ; |
4785 | + mmctrafficM++ ; |
4786 | + } |
4787 | + |
4788 | + lookStack = NULL ; |
4789 | + if (nbChars <= nbmax) { |
4790 | + memcpy(curStackTop,x,nbChars) ; |
4791 | + curStackTop+=nbChars ; |
4792 | + } else { |
4793 | + char *inx = x+(nbChars-nbmax) ; |
4794 | + if (nbmax>0) memcpy(curStackTop,inx,nbmax) ; |
4795 | + while (inx>x) { |
4796 | + if ((curStack == NULL) || (curStack->next == NULL)) { |
4797 | + /* Create new block: */ |
4798 | + DoubleChainedBlock *newStack ; |
4799 | + char *contents = (char*)malloc(ONE_BLOCK_SIZE*sizeof(char)) ; |
4800 | + newStack = (DoubleChainedBlock*)malloc(sizeof(DoubleChainedBlock)) ; |
4801 | + if ((contents == NULL) || (newStack == NULL)) { |
4802 | + DoubleChainedBlock *stack = curStack ; |
4803 | + int nbBlocks = (stack?-1:0) ; |
4804 | + while(stack) { |
4805 | + stack = stack->prev ; |
4806 | + nbBlocks++ ; |
4807 | + } |
4808 | + printf("Out of memory (allocated %i blocks of %i bytes)\n", |
4809 | + nbBlocks, ONE_BLOCK_SIZE) ; |
4810 | + exit(0); |
4811 | + } |
4812 | + if (curStack != NULL) curStack->next = newStack ; |
4813 | + newStack->prev = curStack ; |
4814 | + newStack->next = NULL ; |
4815 | + newStack->contents = contents ; |
4816 | + curStack = newStack ; |
4817 | + /* new block created! */ |
4818 | + } else |
4819 | + curStack = curStack->next ; |
4820 | + inx -= ONE_BLOCK_SIZE ; |
4821 | + if(inx>x) |
4822 | + memcpy(curStack->contents,inx,ONE_BLOCK_SIZE) ; |
4823 | + else { |
4824 | + unsigned int nbhead = (inx-x)+ONE_BLOCK_SIZE ; |
4825 | + curStackTop = curStack->contents ; |
4826 | + memcpy(curStackTop,x,nbhead) ; |
4827 | + curStackTop += nbhead ; |
4828 | + } |
4829 | + } |
4830 | + } |
4831 | +} |
4832 | + |
4833 | +/* POPs "nbChars" consecutive chars to a location starting at address "x". |
4834 | + * Resets the LOOKing position if it was active. |
4835 | + * Checks that there is enough data to fill "nbChars" chars. |
4836 | + * Otherwise, pops as many blocks as necessary. */ |
4837 | +void popNarray(char *x, unsigned int nbChars) { |
4838 | + unsigned int nbmax = curStackTop-(curStack->contents) ; |
4839 | +#ifdef STACK_SIZE_TRACING |
4840 | + bigStackSize -= nbChars; |
4841 | +#endif |
4842 | + lookStack = NULL ; |
4843 | + if (nbChars <= nbmax) { |
4844 | + curStackTop-=nbChars ; |
4845 | + memcpy(x,curStackTop,nbChars); |
4846 | + } else { |
4847 | + char *tlx = x+nbChars ; |
4848 | + if (nbmax>0) memcpy(x,curStack->contents,nbmax) ; |
4849 | + x+=nbmax ; |
4850 | + while (x<tlx) { |
4851 | + curStack = curStack->prev ; |
4852 | + if (curStack==NULL) printf("Popping from an empty stack!!!") ; |
4853 | + if (x+ONE_BLOCK_SIZE<tlx) { |
4854 | + memcpy(x,curStack->contents,ONE_BLOCK_SIZE) ; |
4855 | + x += ONE_BLOCK_SIZE ; |
4856 | + } else { |
4857 | + unsigned int nbtail = tlx-x ; |
4858 | + curStackTop=(curStack->contents)+ONE_BLOCK_SIZE-nbtail ; |
4859 | + memcpy(x,curStackTop,nbtail) ; |
4860 | + x = tlx ; |
4861 | + } |
4862 | + } |
4863 | + } |
4864 | +} |
4865 | + |
4866 | +/* LOOKs "nbChars" consecutive chars to a location starting at address "x". |
4867 | + * Activates the LOOKing position if it was reset. |
4868 | + * LOOKing is just like POPping, except that the main pointer |
4869 | + * remains in place, so that the value is not POPped. |
4870 | + * Further PUSHs or POPs will start from the same place as if |
4871 | + * no LOOK had been made. */ |
4872 | +void lookNarray(char *x, unsigned int nbChars) { |
4873 | + unsigned int nbmax ; |
4874 | + if (lookStack == NULL) { |
4875 | + lookStack = curStack ; |
4876 | + lookStackTop = curStackTop ; |
4877 | + } |
4878 | + nbmax = lookStackTop-(lookStack->contents) ; |
4879 | + if (nbChars <= nbmax) { |
4880 | + lookStackTop-=nbChars ; |
4881 | + memcpy(x,lookStackTop,nbChars); |
4882 | + } else { |
4883 | + char *tlx = x+nbChars ; |
4884 | + if (nbmax>0) memcpy(x,lookStack->contents,nbmax) ; |
4885 | + x+=nbmax ; |
4886 | + while (x<tlx) { |
4887 | + lookStack = lookStack->prev ; |
4888 | + if (lookStack==NULL) printf("Looking into an empty stack!!!") ; |
4889 | + if (x+ONE_BLOCK_SIZE<tlx) { |
4890 | + memcpy(x,lookStack->contents,ONE_BLOCK_SIZE) ; |
4891 | + x += ONE_BLOCK_SIZE ; |
4892 | + } else { |
4893 | + unsigned int nbtail = tlx-x ; |
4894 | + lookStackTop=(lookStack->contents)+ONE_BLOCK_SIZE-nbtail ; |
4895 | + memcpy(x,lookStackTop,nbtail) ; |
4896 | + x = tlx ; |
4897 | + } |
4898 | + } |
4899 | + } |
4900 | +} |
4901 | + |
4902 | +void resetadlookstack_() { |
4903 | + lookStack=NULL ; |
4904 | +} |
4905 | + |
4906 | +/****** Exported PUSH/POP/LOOK functions for ARRAYS: ******/ |
4907 | +/* --> Called from FORTRAN: */ |
4908 | + |
4909 | +void pushcharacterarray_(char *x, unsigned int *n) { |
4910 | + pushNarray(x,*n) ; |
4911 | +} |
4912 | +void popcharacterarray_(char *x, unsigned int *n) { |
4913 | + popNarray(x,*n) ; |
4914 | +} |
4915 | +void lookcharacterarray_(char *x, unsigned int *n) { |
4916 | + lookNarray(x,*n) ; |
4917 | +} |
4918 | + |
4919 | +void pushbooleanarray_(char *x, unsigned int *n) { |
4920 | + pushNarray(x,(*n*4)) ; |
4921 | +} |
4922 | +void popbooleanarray_(char *x, unsigned int *n) { |
4923 | + popNarray(x,(*n*4)) ; |
4924 | +} |
4925 | +void lookbooleanarray_(char *x, unsigned int *n) { |
4926 | + lookNarray(x,(*n*4)) ; |
4927 | +} |
4928 | + |
4929 | +void pushinteger4array_(char *x, unsigned int *n) { |
4930 | + pushNarray(x,(*n*4)) ; |
4931 | +} |
4932 | +void popinteger4array_(char *x, unsigned int *n) { |
4933 | + popNarray(x,(*n*4)) ; |
4934 | +} |
4935 | +void lookinteger4array_(char *x, unsigned int *n) { |
4936 | + lookNarray(x,(*n*4)) ; |
4937 | +} |
4938 | + |
4939 | +void pushinteger8array_(char *x, unsigned int *n) { |
4940 | + pushNarray(x,(*n*8)) ; |
4941 | +} |
4942 | +void popinteger8array_(char *x, unsigned int *n) { |
4943 | + popNarray(x,(*n*8)) ; |
4944 | +} |
4945 | +void lookinteger8array_(char *x, unsigned int *n) { |
4946 | + lookNarray(x,(*n*8)) ; |
4947 | +} |
4948 | + |
4949 | +void pushinteger16array_(char *x, unsigned int *n) { |
4950 | + pushNarray(x,(*n*16)) ; |
4951 | +} |
4952 | +void popinteger16array_(char *x, unsigned int *n) { |
4953 | + popNarray(x,(*n*16)) ; |
4954 | +} |
4955 | +void lookinteger16array_(char *x, unsigned int *n) { |
4956 | + lookNarray(x,(*n*16)) ; |
4957 | +} |
4958 | + |
4959 | +void pushreal4array_(char *x, unsigned int *n) { |
4960 | + pushNarray(x,(*n*4)) ; |
4961 | +} |
4962 | +void popreal4array_(char *x, unsigned int *n) { |
4963 | + popNarray(x,(*n*4)) ; |
4964 | +} |
4965 | +void lookreal4array_(char *x, unsigned int *n) { |
4966 | + lookNarray(x,(*n*4)) ; |
4967 | +} |
4968 | + |
4969 | +void pushreal8array_(char *x, unsigned int *n) { |
4970 | + pushNarray(x,(*n*8)) ; |
4971 | +} |
4972 | +void popreal8array_(char *x, unsigned int *n) { |
4973 | + popNarray(x,(*n*8)) ; |
4974 | +} |
4975 | +void lookreal8array_(char *x, unsigned int *n) { |
4976 | + lookNarray(x,(*n*8)) ; |
4977 | +} |
4978 | + |
4979 | +void pushreal16array_(char *x, unsigned int *n) { |
4980 | + pushNarray(x,(*n*16)) ; |
4981 | +} |
4982 | +void popreal16array_(char *x, unsigned int *n) { |
4983 | + popNarray(x,(*n*16)) ; |
4984 | +} |
4985 | +void lookreal16array_(char *x, unsigned int *n) { |
4986 | + lookNarray(x,(*n*16)) ; |
4987 | +} |
4988 | + |
4989 | +void pushreal32array_(char *x, unsigned int *n) { |
4990 | + pushNarray(x,(*n*32)) ; |
4991 | +} |
4992 | +void popreal32array_(char *x, unsigned int *n) { |
4993 | + popNarray(x,(*n*32)) ; |
4994 | +} |
4995 | +void lookreal32array_(char *x, unsigned int *n) { |
4996 | + lookNarray(x,(*n*32)) ; |
4997 | +} |
4998 | + |
4999 | +void pushcomplex4array_(char *x, unsigned int *n) { |
5000 | + pushNarray(x,(*n*4)) ; |
For posterity, David's review requests were:
- get rid of the boundary_condition control from the schema -- the code currently doesn't honour it. 4_5_OR_ NEWER that David made
- remove the commented-out comparison code in advection_action in the burgers adjoint callbacks
- Makefile targets for ADing simple advection (but I don't think I can do this one)
- Rather than checking if gfortran version is >= 4.5 myself, use the handy env variable $GFORTRAN_
- the testharness should filter out long tests, by default
- have the testharness print out the criteria it's using to search for tests.
These were fixed in r3593.