10 implicit none ;
private
25 integer,
parameter ::
mlen = 1240
29 integer :: unitall = -1
30 integer :: unitshort = -1
31 integer :: unitlayout = -1
32 integer :: unitdebugging = -1
33 logical :: filesareopen = .false.
34 character(len=mLen) :: docfilebase =
''
36 logical :: complete = .true.
37 logical :: minimal = .true.
38 logical :: layout = .true.
39 logical :: debugging = .true.
40 logical :: definesyntax = .false.
41 logical :: warnonconflicts = .false.
42 integer :: commentcolumn = 32
43 integer :: max_line_len = 112
45 character(len=240) :: blockprefix =
''
51 character(len=80) :: name
52 character(len=620) :: msg
66 character(len=*),
intent(in) :: varname
67 character(len=*),
intent(in) :: desc
68 character(len=*),
intent(in) :: units
71 character(len=mLen) :: mesg
73 if (.not. (
is_root_pe() .and.
associated(doc)))
return
76 if (doc%filesAreOpen)
then
77 numspc = max(1,doc%commentColumn-8-len_trim(varname))
78 mesg =
"#define "//trim(varname)//repeat(
" ",numspc)//
"!"
79 if (len_trim(units) > 0) mesg = trim(mesg)//
" ["//trim(units)//
"]"
88 layoutParam, debuggingParam)
91 character(len=*),
intent(in) :: varname
92 character(len=*),
intent(in) :: desc
93 character(len=*),
intent(in) :: units
94 logical,
intent(in) :: val
95 logical,
optional,
intent(in) :: default
96 logical,
optional,
intent(in) :: layoutParam
97 logical,
optional,
intent(in) :: debuggingParam
99 character(len=mLen) :: mesg
100 logical :: equalsDefault
102 if (.not. (
is_root_pe() .and.
associated(doc)))
return
105 if (doc%filesAreOpen)
then
112 equalsdefault = .false.
113 if (
present(default))
then
114 if (val .eqv. default) equalsdefault = .true.
124 layoutparam=layoutparam, debuggingparam=debuggingparam)
130 layoutParam, debuggingParam)
133 character(len=*),
intent(in) :: varname
134 character(len=*),
intent(in) :: desc
135 character(len=*),
intent(in) :: units
136 logical,
intent(in) :: vals(:)
137 logical,
optional,
intent(in) :: default
138 logical,
optional,
intent(in) :: layoutParam
139 logical,
optional,
intent(in) :: debuggingParam
142 character(len=mLen) :: mesg
143 character(len=mLen) :: valstring
144 logical :: equalsDefault
146 if (.not. (
is_root_pe() .and.
associated(doc)))
return
149 if (doc%filesAreOpen)
then
151 do i=2,min(
size(vals),128)
161 equalsdefault = .false.
162 if (
present(default))
then
163 equalsdefault = .true.
164 do i=1,
size(vals) ;
if (vals(i) .neqv. default) equalsdefault = .false. ;
enddo
174 layoutparam=layoutparam, debuggingparam=debuggingparam)
179 subroutine doc_param_int(doc, varname, desc, units, val, default, &
180 layoutParam, debuggingParam)
183 character(len=*),
intent(in) :: varname
184 character(len=*),
intent(in) :: desc
185 character(len=*),
intent(in) :: units
186 integer,
intent(in) :: val
187 integer,
optional,
intent(in) :: default
188 logical,
optional,
intent(in) :: layoutParam
189 logical,
optional,
intent(in) :: debuggingParam
191 character(len=mLen) :: mesg
192 character(len=doc%commentColumn) :: valstring
193 logical :: equalsDefault
195 if (.not. (
is_root_pe() .and.
associated(doc)))
return
198 if (doc%filesAreOpen)
then
202 equalsdefault = .false.
203 if (
present(default))
then
204 if (val == default) equalsdefault = .true.
205 mesg = trim(mesg)//
" default = "//(trim(
int_string(default)))
210 layoutparam=layoutparam, debuggingparam=debuggingparam)
216 layoutParam, debuggingParam)
219 character(len=*),
intent(in) :: varname
220 character(len=*),
intent(in) :: desc
221 character(len=*),
intent(in) :: units
222 integer,
intent(in) :: vals(:)
223 integer,
optional,
intent(in) :: default
224 logical,
optional,
intent(in) :: layoutParam
225 logical,
optional,
intent(in) :: debuggingParam
228 character(len=mLen) :: mesg
229 character(len=mLen) :: valstring
230 logical :: equalsDefault
232 if (.not. (
is_root_pe() .and.
associated(doc)))
return
235 if (doc%filesAreOpen)
then
237 do i=2,min(
size(vals),128)
238 valstring = trim(valstring)//
", "//trim(
int_string(vals(i)))
243 equalsdefault = .false.
244 if (
present(default))
then
245 equalsdefault = .true.
246 do i=1,
size(vals) ;
if (vals(i) /= default) equalsdefault = .false. ;
enddo
247 mesg = trim(mesg)//
" default = "//(trim(
int_string(default)))
252 layoutparam=layoutparam, debuggingparam=debuggingparam)
258 subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam)
261 character(len=*),
intent(in) :: varname
262 character(len=*),
intent(in) :: desc
263 character(len=*),
intent(in) :: units
264 real,
intent(in) :: val
265 real,
optional,
intent(in) :: default
266 logical,
optional,
intent(in) :: debuggingParam
268 character(len=mLen) :: mesg
269 character(len=doc%commentColumn) :: valstring
270 logical :: equalsDefault
272 if (.not. (
is_root_pe() .and.
associated(doc)))
return
275 if (doc%filesAreOpen)
then
279 equalsdefault = .false.
280 if (
present(default))
then
281 if (val == default) equalsdefault = .true.
282 mesg = trim(mesg)//
" default = "//trim(
real_string(default))
287 debuggingparam=debuggingparam)
295 character(len=*),
intent(in) :: varname
296 character(len=*),
intent(in) :: desc
297 character(len=*),
intent(in) :: units
298 real,
intent(in) :: vals(:)
299 real,
optional,
intent(in) :: default
300 logical,
optional,
intent(in) :: debuggingParam
303 character(len=mLen) :: mesg
304 character(len=mLen) :: valstring
305 logical :: equalsDefault
307 if (.not. (
is_root_pe() .and.
associated(doc)))
return
310 if (doc%filesAreOpen)
then
315 equalsdefault = .false.
316 if (
present(default))
then
317 equalsdefault = .true.
318 do i=1,
size(vals) ;
if (vals(i) /= default) equalsdefault = .false. ;
enddo
319 mesg = trim(mesg)//
" default = "//trim(
real_string(default))
324 debuggingparam=debuggingparam)
330 subroutine doc_param_char(doc, varname, desc, units, val, default, &
331 layoutParam, debuggingParam)
334 character(len=*),
intent(in) :: varname
335 character(len=*),
intent(in) :: desc
336 character(len=*),
intent(in) :: units
337 character(len=*),
intent(in) :: val
339 optional,
intent(in) :: default
340 logical,
optional,
intent(in) :: layoutParam
341 logical,
optional,
intent(in) :: debuggingParam
343 character(len=mLen) :: mesg
344 logical :: equalsDefault
346 if (.not. (
is_root_pe() .and.
associated(doc)))
return
349 if (doc%filesAreOpen)
then
352 equalsdefault = .false.
353 if (
present(default))
then
354 if (trim(val) == trim(default)) equalsdefault = .true.
355 mesg = trim(mesg)//
' default = "'//trim(adjustl(default))//
'"'
360 layoutparam=layoutparam, debuggingparam=debuggingparam)
369 character(len=*),
intent(in) :: blockname
370 character(len=*),
optional,
intent(in) :: desc
372 character(len=mLen) :: mesg
373 character(len=doc%commentColumn) :: valstring
375 if (.not. (
is_root_pe() .and.
associated(doc)))
return
378 if (doc%filesAreOpen)
then
379 mesg = trim(blockname)//
'%'
381 if (
present(desc))
then
387 doc%blockPrefix = trim(doc%blockPrefix)//trim(blockname)//
'%'
394 character(len=*),
intent(in) :: blockname
396 character(len=mLen) :: mesg
397 character(len=doc%commentColumn) :: valstring
400 if (.not. (
is_root_pe() .and.
associated(doc)))
return
403 if (doc%filesAreOpen)
then
404 mesg =
'%'//trim(blockname)
408 i = index(trim(doc%blockPrefix), trim(blockname)//
'%', .true.)
410 doc%blockPrefix = trim(doc%blockPrefix(1:i-1))
417 subroutine doc_param_time(doc, varname, desc, units, val, default, &
418 layoutParam, debuggingParam)
421 character(len=*),
intent(in) :: varname
422 character(len=*),
intent(in) :: desc
423 character(len=*),
intent(in) :: units
424 type(time_type),
intent(in) :: val
425 type(time_type),
optional,
intent(in) :: default
426 logical,
optional,
intent(in) :: layoutParam
427 logical,
optional,
intent(in) :: debuggingParam
431 character(len=mLen) :: mesg
432 logical :: equalsDefault
434 if (.not. (
is_root_pe() .and.
associated(doc)))
return
437 equalsdefault = .false.
438 if (doc%filesAreOpen)
then
439 numspc = max(1,doc%commentColumn-18-len_trim(varname))
440 mesg =
"#define "//trim(varname)//
" Time-type"//repeat(
" ",numspc)//
"!"
441 if (len_trim(units) > 0) mesg = trim(mesg)//
" ["//trim(units)//
"]"
445 layoutparam=layoutparam, debuggingparam=debuggingparam)
452 layoutParam, debuggingParam)
455 character(len=*),
intent(in) :: vmesg
456 character(len=*),
intent(in) :: desc
457 logical,
optional,
intent(in) :: valueWasDefault
458 integer,
optional,
intent(in) :: indent
459 logical,
optional,
intent(in) :: layoutParam
460 logical,
optional,
intent(in) :: debuggingParam
463 character(len=mLen) :: mesg
464 character(len=mLen) :: mesg_text
465 integer :: start_ind = 1
466 integer :: nl_ind, tab_ind, end_ind
467 integer :: len_text, len_tab, len_nl
468 integer :: indnt, msg_pad
469 logical :: msg_done, reset_msg_pad
470 logical :: all, short, layout, debug
472 layout = .false. ;
if (
present(layoutparam)) layout = layoutparam
473 debug = .false. ;
if (
present(debuggingparam)) debug = debuggingparam
474 all = doc%complete .and. (doc%unitAll > 0) .and. .not. (layout .or. debug)
475 short = doc%minimal .and. (doc%unitShort > 0) .and. .not. (layout .or. debug)
476 if (
present(valuewasdefault)) short = short .and. (.not. valuewasdefault)
478 if (all)
write(doc%unitAll,
'(a)') trim(vmesg)
479 if (short)
write(doc%unitShort,
'(a)') trim(vmesg)
480 if (layout)
write(doc%unitLayout,
'(a)') trim(vmesg)
481 if (debug)
write(doc%unitDebugging,
'(a)') trim(vmesg)
483 if (len_trim(desc) == 0)
return
485 len_tab = len_trim(
"_\t_") - 2
486 len_nl = len_trim(
"_\n_") - 2
488 indnt = doc%commentColumn ;
if (
present(indent)) indnt = indent
489 len_text = doc%max_line_len - (indnt + 2)
490 start_ind = 1 ; msg_pad = 0 ; msg_done = .false.
492 if (len_trim(desc(start_ind:)) < 1)
exit
494 nl_ind = index(desc(start_ind:),
"\n")
497 if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_text-msg_pad))
then
499 end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)),
" ", back=.true.) - 1
500 if (end_ind > 0) nl_ind = 0
501 elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_text-msg_pad))
then
503 end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)),
" ", back=.true.) - 1
506 reset_msg_pad = .false.
508 mesg_text = trim(desc(start_ind:start_ind+nl_ind-2))
509 start_ind = start_ind + nl_ind + len_nl - 1
510 reset_msg_pad = .true.
511 elseif (end_ind > 0)
then
512 mesg_text = trim(desc(start_ind:start_ind+end_ind))
513 start_ind = start_ind + end_ind + 1
515 start_ind = start_ind + (len_trim(desc(start_ind:)) - len_trim(adjustl(desc(start_ind:))))
517 mesg_text = trim(desc(start_ind:))
521 do ; tab_ind = index(mesg_text,
"\t")
522 if (tab_ind == 0)
exit
523 mesg_text(tab_ind:) =
" "//trim(mesg_text(tab_ind+len_tab:))
526 mesg = repeat(
" ",indnt)//
"! "//repeat(
" ",msg_pad)//trim(mesg_text)
528 if (reset_msg_pad)
then
530 elseif (msg_pad == 0)
then
531 msg_pad = len_trim(mesg_text) - len_trim(adjustl(mesg_text))
533 if (msg_pad >= 2) msg_pad = msg_pad + 2
536 if (all)
write(doc%unitAll,
'(a)') trim(mesg)
537 if (short)
write(doc%unitShort,
'(a)') trim(mesg)
538 if (layout)
write(doc%unitLayout,
'(a)') trim(mesg)
539 if (debug)
write(doc%unitDebugging,
'(a)') trim(mesg)
550 real,
intent(in) :: val
555 if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3))
then
574 if ((len<2) .or. (
real_string(len-1:len) ==
".0") .or. &
578 elseif (val == 0.)
then
581 if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100))
then
604 real,
intent(in) :: vals(:)
606 optional,
intent(in) :: sep
611 integer :: j, n, b, ns
613 character(len=10) :: separator
615 if (
present(sep))
then
616 separator=sep ; ns=len(sep)
618 separator=
', ' ; ns=2
622 if (j<
size(vals))
then
623 if (vals(j)==vals(j+1))
then
645 character(len=*),
intent(in) :: str
646 real,
intent(in) :: val
651 read(str(1:),*) scannedval
652 if (scannedval == val)
then
661 integer,
intent(in) :: val
670 logical,
intent(in) :: val
681 character(len=*),
intent(in) :: varname
682 character(len=*),
intent(in) :: valstring
683 character(len=*),
intent(in) :: units
688 if (doc%defineSyntax)
then
693 numspaces = max(1, doc%commentColumn - len_trim(
define_string) )
702 character(len=*),
intent(in) :: varname
703 character(len=*),
intent(in) :: units
709 if (doc%defineSyntax)
then
714 numspaces = max(1, doc%commentColumn - len_trim(
undef_string) )
725 character(len=*),
intent(in) :: modname
726 character(len=*),
intent(in) :: desc
728 character(len=mLen) :: mesg
730 if (.not. (
is_root_pe() .and.
associated(doc)))
return
733 if (doc%filesAreOpen)
then
735 mesg =
"! === module "//trim(modname)//
" ==="
744 character(len=*),
intent(in) :: modname
745 character(len=*),
intent(in) :: subname
746 character(len=*),
intent(in) :: desc
748 if (.not. (
is_root_pe() .and.
associated(doc)))
return
757 character(len=*),
intent(in) :: modname
758 character(len=*),
intent(in) :: fnname
759 character(len=*),
intent(in) :: desc
761 if (.not. (
is_root_pe() .and.
associated(doc)))
return
769 subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging)
770 character(len=*),
intent(in) :: docfilebase
774 logical,
optional,
intent(in) :: minimal
776 logical,
optional,
intent(in) :: complete
778 logical,
optional,
intent(in) :: layout
780 logical,
optional,
intent(in) :: debugging
783 if (.not.
associated(doc))
then
787 doc%docFileBase = docfilebase
788 if (
present(minimal)) doc%minimal = minimal
789 if (
present(complete)) doc%complete = complete
790 if (
present(layout)) doc%layout = layout
791 if (
present(debugging)) doc%debugging = debugging
802 logical :: opened, new_file
804 character(len=240) :: fileName
806 if (.not. (
is_root_pe() .and.
associated(doc)))
return
808 if ((len_trim(doc%docFileBase) > 0) .and. doc%complete .and. (doc%unitAll<0))
then
809 new_file = .true. ;
if (doc%unitAll /= -1) new_file = .false.
812 write(filename(1:240),
'(a)') trim(doc%docFileBase)//
'.all'
814 open(doc%unitAll, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
815 action=
'WRITE', status=
'REPLACE', iostat=ios)
816 write(doc%unitAll,
'(a)') &
817 '! This file was written by the model and records all non-layout '//&
818 'or debugging parameters used at run-time.'
820 open(doc%unitAll, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
821 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
823 inquire(doc%unitAll, opened=opened)
824 if ((.not.opened) .or. (ios /= 0))
then
825 call mom_error(fatal,
"Failed to open doc file "//trim(filename)//
".")
827 doc%filesAreOpen = .true.
830 if ((len_trim(doc%docFileBase) > 0) .and. doc%minimal .and. (doc%unitShort<0))
then
831 new_file = .true. ;
if (doc%unitShort /= -1) new_file = .false.
834 write(filename(1:240),
'(a)') trim(doc%docFileBase)//
'.short'
836 open(doc%unitShort, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
837 action=
'WRITE', status=
'REPLACE', iostat=ios)
838 write(doc%unitShort,
'(a)') &
839 '! This file was written by the model and records the non-default parameters used at run-time.'
841 open(doc%unitShort, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
842 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
844 inquire(doc%unitShort, opened=opened)
845 if ((.not.opened) .or. (ios /= 0))
then
846 call mom_error(fatal,
"Failed to open doc file "//trim(filename)//
".")
848 doc%filesAreOpen = .true.
851 if ((len_trim(doc%docFileBase) > 0) .and. doc%layout .and. (doc%unitLayout<0))
then
852 new_file = .true. ;
if (doc%unitLayout /= -1) new_file = .false.
855 write(filename(1:240),
'(a)') trim(doc%docFileBase)//
'.layout'
857 open(doc%unitLayout, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
858 action=
'WRITE', status=
'REPLACE', iostat=ios)
859 write(doc%unitLayout,
'(a)') &
860 '! This file was written by the model and records the layout parameters used at run-time.'
862 open(doc%unitLayout, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
863 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
865 inquire(doc%unitLayout, opened=opened)
866 if ((.not.opened) .or. (ios /= 0))
then
867 call mom_error(fatal,
"Failed to open doc file "//trim(filename)//
".")
869 doc%filesAreOpen = .true.
872 if ((len_trim(doc%docFileBase) > 0) .and. doc%debugging .and. (doc%unitDebugging<0))
then
873 new_file = .true. ;
if (doc%unitDebugging /= -1) new_file = .false.
876 write(filename(1:240),
'(a)') trim(doc%docFileBase)//
'.debugging'
878 open(doc%unitDebugging, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
879 action=
'WRITE', status=
'REPLACE', iostat=ios)
880 write(doc%unitDebugging,
'(a)') &
881 '! This file was written by the model and records the debugging parameters used at run-time.'
883 open(doc%unitDebugging, file=trim(filename), access=
'SEQUENTIAL', form=
'FORMATTED', &
884 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
886 inquire(doc%unitDebugging, opened=opened)
887 if ((.not.opened) .or. (ios /= 0))
then
888 call mom_error(fatal,
"Failed to open doc file "//trim(filename)//
".")
890 doc%filesAreOpen = .true.
903 if (.not.opened)
exit
906 "doc_init failed to find an unused unit number.")
914 type(
link_msg),
pointer :: this => null(), next => null()
916 if (.not.
associated(doc))
return
918 if (doc%unitAll > 0)
then
923 if (doc%unitShort > 0)
then
928 if (doc%unitLayout > 0)
then
929 close(doc%unitLayout)
933 if (doc%unitDebugging > 0)
then
934 close(doc%unitDebugging)
935 doc%unitDebugging = -2
938 doc%filesAreOpen = .false.
940 this => doc%chain_msg
941 do while(
associated(this) )
954 character(len=*),
intent(in) :: varname
955 character(len=*),
intent(in) :: mesg
959 type(
link_msg),
pointer :: newlink => null(), this => null(), last => null()
967 this => doc%chain_msg
968 do while(
associated(this) )
969 if (trim(doc%blockPrefix)//trim(varname) == trim(this%name))
then
971 if (trim(mesg) == trim(this%msg))
return
973 if (mesg(1:1) ==
'!')
return
974 call mom_error(warning,
"Previous msg:"//trim(this%msg))
975 call mom_error(warning,
"New message :"//trim(mesg))
976 call mom_error(warning,
"Encountered inconsistent documentation line for parameter "&
977 //trim(varname)//
"!")
985 newlink%name = trim(doc%blockPrefix)//trim(varname)
986 newlink%msg = trim(mesg)
987 newlink%next => null()
988 if (.not.
associated(doc%chain_msg))
then
989 doc%chain_msg => newlink
991 if (.not.
associated(last))
call mom_error(fatal, &
992 "Unassociated LINK in mesgHasBeenDocumented: "//trim(mesg))