*+ image_edit

       subroutine image_edit( interp, cdata, map_array, status )
C      ---------------------------------------------------------
C
C Sub-system to edit an image
C
C Updated:
C    command interpreter data structure
       integer       interp(*)
C    command language data structure
       integer       cdata(*)
C    map data array
       real*4        map_array(*)
C Returned:
C    error status
       integer       status
C
C A command line driven sub-system to edit an image.  Facilities are
C provided to set regions of an image to a defined value, copy
C parts of an image and reset values in an image.
C
C P. Alexander, MRAO, Cambridge
C Version 2.0. December 1993
C-

       include '../include/anmap_sys_pars.inc'
       include '/mrao/include/iolib_constants.inc'
       include '/mrao/include/iolib_errors.inc'
       include '/mrao/include/chrlib_functions.inc'
       include '/mrao/include/iolib_functions.inc'

C Local variables
C ---------------
C  command line interpretation
       integer            number_commands, icom
       parameter         (number_commands = 30)
       character*80       liscom(number_commands),
     *                    option_list(12), option, sm_prompt
C  catalogue entries
       integer            imap, imapo, iedit, ip_map, ip_edit
       character          string*40
C  size and range on the mask
       integer            nx, ny, u1, u2, v1, v2
       integer            minirt(8), uvr(4), to_uvr(4), from_uvr(4)
       equivalence       (minirt(1), uvr(1))
       equivalence       (minirt(1), u1)
       equivalence       (minirt(2), u2)
       equivalence       (minirt(3), v1)
       equivalence       (minirt(4), v2)
       equivalence       (minirt(5), nx)
       equivalence       (minirt(6), ny)
C  map functions
       integer            iuvmap2
C  redtape information
       integer            map_minirt(8)
C  counters
       integer            i, j, iu, iv
       integer            uv_pix(2), to_pix(2), from_pix(2)
       equivalence       (uv_pix(1), iu)
       equivalence       (uv_pix(2), iv)
C  variables used in defining mask
       real*4             uv_pos(2), to_pos(2), rad1, rad2,
     *                    SD, mean, blank, fixed, blank_new,
     *                    scale, zero, x, y, gate_1, gate_2
C  type of replacement
      integer             replacement_mode, add_mode, edit_mode
C  function definition
      character*256       function
      integer             lf
C  dump array for redtape
      integer             rt(1024)

C  save all control information for editing
       common /save_image_edit/ imap, iedit, ip_edit, replacement_mode,
     *                          add_mode, blank, fixed, SD, mean,
     *                          scale, zero, map_minirt, edit_mode,
     *                          gate_1, gate_2
       common /char_image_edit/ sm_prompt

C  functions
       real*4             imed_value, image_polcorr

C define commands
       data liscom(1) /
     *  'set-map .................. set map to edit'
     *                /
       data liscom(2) /
     *  'create-map ............... create a new output map'
     *                /
       data liscom(3)/
     *  'update-map ............... open a map for update'
     *                /
       data liscom(4) /
     *  'save-edits ............... save the current edits'
     *                /
       data liscom(5) /
     *  'discard-edits ............ end editing without saving'
     *                /
       data liscom(6) /
     *  'set-pixel ................ set pixel value'
     *                /
       data liscom(7) /
     *  'set-region ............... set values in a UV-region'
     *                /
       data liscom(8) /
     *  'set-circle ............... set values in a circular region'
     *                /
       data liscom(9) /
     *  'set-annulus .............. set values in an annulus'
     *                /
       data liscom(10)/
     *  'set-row .................. set values in a row'
     *                /
       data liscom(11)/
     *  'set-column ............... set values in a column'
     *                /
       data liscom(12)/
     *  'set-full-image ........... set values in complete image'
     *                /
       data liscom(13)/
     *  'set-source ............... set source name in output'
     *                /
       data liscom(14)/
     *  'set-program .............. set program name in output'
     *                /
       data liscom(15)/
     *  'copy-pixel ............... copy pixel value on image'
     *                /
       data liscom(16)/
     *  'copy-region .............. copy UV-region on image'
     *                /
       data liscom(17)/
     *  'copy-row ................. copy row on image'
     *                /
       data liscom(18)/
     *  'copy-column .............. copy column on image'
     *                /
       data liscom(19)/
     *  'copy-from-image .......... copy region from another image'
     *                /
       data liscom(20)/
     *  'select-value-mode ........ specify the replacement value'
     *                /
       data liscom(21)/
     *  'select-noise-mode ........ specify replacement to be noise'
     *                /
       data liscom(22)/
     *  'select-scale-mode ........ specify replacement to be scaling'
     *                /
       data liscom(23)/
     *  'select-blanking-mode ..... specify replacement is blanking'
     *                /
       data liscom(24)/
     *  'select-filter-mode ....... specify mode to be filter'
     *                /
       data liscom(25)/
     *  'define-blank ............. define value for "blank"'
     *                /
       data liscom(26)/
     *  'reset-blank-values ....... reset values of blank pixels'
     *                /
       data liscom(27)/
     *  'apply-ricean-correction .. apply correction for ricean errors'
     *                /
       data liscom(28)/
     *  'mask-map ................. use edits as a mask'
     *                /
       data liscom(29)/
     *  'function ................. define a function in a region'
     *                /
       data liscom(30)/
     *  'edit-options ............. specify options to edit-image'
     *                /

C check status on entry
       if (status.ne.0) return
       call ldredt( rt, status )
       rad1 = 0.0
       rad2 = 10000.0
       uv_pos(1) = 0.0
       uv_pos(2) = 0.0
       call cmd_getcmd( 'Edit-image> ',liscom,number_commands,
     *                  icom,status)

       if (status.ne.0) then
         call cmd_err(status,'Edit-Image',' ')
         cdata(1) = 100
         return
       end if

C decode command
       if (chr_cmatch('set-map',liscom(icom))) then
         if (chr_lenb(sm_prompt).gt.0) then
           call mapcat_getmap(sm_prompt(1:chr_lenb(sm_prompt)+1),
     *                        'default_map',
     *                        'READ',imap,status)
         else
           call mapcat_getmap('Catalogue-entry : ','default_map',
     *                        'READ',imap,status)
         endif

C .. save any existing edits and allocate a new output map
         if (iedit.ne.-1) then
           call map_end_alloc( iedit, map_array, status )
         end if
         call map_alloc_toout(imap,'DIRECT',map_array,
     *                        iedit,ip_edit,status)
         call redt_load(imap,status)
         call enminirt( map_minirt, status )
         call ennull( blank, status )

       elseif (chr_cmatch('update-map',liscom(icom))) then
         call mapcat_getmap('Map-entry : ','default_map',
     *                      'READ',imap,status)
C .. save any existing edits and allocate a new output map
         if (iedit.ne.-1) then
           call map_end_alloc( iedit, map_array, status )
         end if
         call map_alloc_in(imap,'DIRECT',map_array,ip_edit,status)
         iedit = imap
         call redt_load(imap,status)
         call enminirt( map_minirt, status )
         call ennull( blank, status )
         call mapcat_acc(iedit,'CLEAR',status)
         call mapcat_acc(iedit,'WRITE',status)

       else if (chr_cmatch('create-map',liscom(icom))) then
         if (iedit.ne.-1) then
           call map_end_alloc( iedit, map_array, status )
         end if
         call io_getni('UV-range for image : ','*',map_minirt,4,status)
         if (map_minirt(1).gt.map_minirt(2)) then
           i = map_minirt(1)
           map_minirt(1) = map_minirt(2)
           map_minirt(2) = i
         endif
         if (map_minirt(4).gt.map_minirt(3)) then
           i = map_minirt(4)
           map_minirt(4) = map_minirt(3)
           map_minirt(3) = i
         endif
         map_minirt(5) = map_minirt(2) - map_minirt(1) + 1
         map_minirt(6) = map_minirt(3) - map_minirt(4) + 1
         call nwredt(map_minirt(5), map_minirt(6), 3, 0, status )
         call adredt( 'CREATED', 'EDITIMAGE', status )
         call io_getstr( 'Source-name : ',' ',string,status )
         call adredt( 'SOURCE', string, status )
         call stmapc( 1.0D+0,1.0D+0,1950.0D+0,1950.0D+0,string,status )
         call stmapj( 2,1.0D+0,0.0D+0,1950.0D+0,0.0D+0,status )
         call sttype( 0.0,-1,'NONE','NONE',status )
         if (map_minirt(5).gt.0 .and. map_minirt(6).gt.0) then
           call map_alloc_out(map_minirt(5),map_minirt(6),'DIRECT',
     *                        iedit,ip_edit,status)
           call enminirt(map_minirt,status)
           call mapcat_setsr(iedit,string,'EDITIMAGE',status)
         endif
         call ennull( blank, status )

       else if (chr_cmatch('save-edits',liscom(icom))) then
         if (iedit.gt.0) then
           call stnull( blank, status )
           call map_end_alloc( iedit, map_array, status )
           iedit = -1
         endif

       else if (chr_cmatch('discard-edits',liscom(icom))) then
         i = -10
         call map_end_alloc( iedit, map_array, i )
         iedit = -1

       else if (chr_cmatch('set-pixel',liscom(icom))) then
         call plot_getpos2(map_minirt,'UV-position : ','*',
     *                    uv_pos,status)
         uv_pix(1) = nint(uv_pos(1))
         uv_pix(2) = nint(uv_pos(2))
         if (status.eq.0) then
            i = iuvmap2(map_minirt,uv_pix)
            map_array(ip_edit+i-1)=imed_value(map_array(ip_edit+i-1))
         end if
         call cmd_err( status,'Set-Pixel','Failed' )

       else if (chr_cmatch('set-region',liscom(icom))) then
         do i=1,8
           minirt(i) = map_minirt(i)
         enddo
         call plot_getuv2(map_minirt,'UV-region : ','*',uvr,status)
         if (status.eq.0) then
           do iv=uvr(3),uvr(4),-1
             do iu=uvr(1),uvr(2)
               i = iuvmap2(map_minirt,uv_pix)
               map_array(ip_edit+i-1)=imed_value(map_array(ip_edit+i-1))
             end do
           end do
         end if
         call cmd_err( status,'Set-Region','Failed' )

       else if (chr_cmatch('set-circle',liscom(icom))) then
         uv_pos(1) = 0.0
         uv_pos(2) = 0.0
         call plot_getpos2(map_minirt,'UV-centre : ','*',uv_pos,status)
         call io_getr('Radius (pixels) : ','*',rad1,status)
         if (status.eq.0) then
           do iv=map_minirt(3),map_minirt(4),-1
             do iu=map_minirt(1),map_minirt(2)
               i = iuvmap2(map_minirt,uv_pix)
               if ( ((uv_pix(1)-uv_pos(1))**2+(uv_pix(2)-uv_pos(2))**2)
     *              .le.(rad1*rad1)) then
                 map_array(ip_edit+i-1)=
     *             imed_value(map_array(ip_edit+i-1))
               end if
             end do
           end do
         end if
         call cmd_err( status,'Set-Circle','Failed' )

       else if (chr_cmatch('set-annulus',liscom(icom))) then
         uv_pos(1) = 0.0
         uv_pos(2) = 0.0
         call plot_getpos2(map_minirt,'UV-centre : ','*',uv_pos,status)
         call io_getr('Inner-Radius (pixels) : ','*',rad1,status)
         call io_getr('Outer-Radius (pixels) : ','*',rad2,status)
         if (status.eq.0) then
           do iv=map_minirt(3),map_minirt(4),-1
             do iu=map_minirt(1),map_minirt(2)
               i = iuvmap2(map_minirt,uv_pix)
               if (
     *            ( ((uv_pix(1)-uv_pos(1))**2+(uv_pix(2)-uv_pos(2))**2)
     *               .ge.(rad1*rad1) ) .and.
     *            ( ((uv_pix(1)-uv_pos(1))**2+(uv_pix(2)-uv_pos(2))**2)
     *               .le.(rad2*rad2) ) ) then
                 map_array(ip_edit+i-1) =
     *              imed_value(map_array(ip_edit+i-1))
               end if
             end do
           end do
         end if
         call cmd_err( status,'Set-Annulus','Failed' )

       else if (chr_cmatch('set-row',liscom(icom))) then
         uv_pos(1) = 0.0
         uv_pos(2) = 0.0
         call plot_getrow2(map_minirt,'UV-row : ','*',
     *                    uv_pos(2),status)
         uv_pix(2) = nint(uv_pos(2))
         if (status.eq.0) then
           do iu=map_minirt(1),map_minirt(2)
               i = iuvmap2(map_minirt,uv_pix)
               map_array(ip_edit+i-1) =
     *            imed_value(map_array(ip_edit+i-1))
           end do
         end if
         call cmd_err( status,'Set-Row','Failed' )

       else if (chr_cmatch('set-column',liscom(icom))) then
         uv_pos(1) = 0.0
         uv_pos(2) = 0.0
         call plot_getcol2(map_minirt,'UV-column : ','*',
     *                    uv_pos(1),status)
         uv_pix(1) = nint(uv_pos(1))
         if (status.eq.0) then
           do iv=map_minirt(3),map_minirt(4),-1
               i = iuvmap2(map_minirt,uv_pix)
               map_array(ip_edit+i-1) =
     *            imed_value(map_array(ip_edit+i-1))
           end do
         end if
         call cmd_err( status,'Set-Column','Failed' )

       else if (chr_cmatch('set-full-image',liscom(icom))) then
         do i=1,map_minirt(5)*map_minirt(6)
            map_array(ip_edit+i-1)=imed_value(map_array(ip_edit+i-1))
         end do
         call cmd_err( status,'Set-Full-Image','Failed' )

       else if (chr_cmatch('set-source',liscom(icom))) then
         string = ' '
         call io_getstr('Source : ',' ',string,status)
         call adredt('SOURCE',string,status)
         call cmd_err( status,'Set-Source','Failed' )

       else if (chr_cmatch('set-program',liscom(icom))) then
         string = ' '
         call io_getstr('Program : ',' ',string,status)
         call adredt('CREATED',string,status)
         call cmd_err( status,'Set-Program','Failed' )

       else if (chr_cmatch('copy-pixel',liscom(icom))) then
         call plot_getpos2(map_minirt,'From-UV-position : ','*',
     *                    uv_pos,status)
         call plot_getpos2(map_minirt,'To-UV-position : ','*',
     *                    to_pos,status)
         uv_pix(1) = nint(uv_pos(1))
         uv_pix(2) = nint(uv_pos(2))
         to_pix(1) = nint(to_pos(1))
         to_pix(2) = nint(to_pos(2))
         if (status.eq.0) then
            i = iuvmap2(map_minirt,uv_pix)
            j = iuvmap2(map_minirt,to_pix)
            map_array(ip_edit+i-1) =
     *            map_array(ip_edit+j-1)
         end if
         call cmd_err( status,'Copy-Pixel','Failed' )

       else if (chr_cmatch('copy-region',liscom(icom))) then
         do i=1,8
           minirt(i) = map_minirt(i)
         enddo
         call plot_getuv2(map_minirt,'From-UV-region : ','*',uvr,status)
         call plot_getpos2(map_minirt,'To-BLC : ','*',to_pos,status)
         to_pix(1) = nint(to_pos(1))
         to_pix(2) = nint(to_pos(2))
         to_uvr(1) = to_pix(1)
         to_uvr(2) = to_pix(1) + uvr(2) - uvr(1)
         to_uvr(4) = to_pix(2)
         to_uvr(3) = to_pix(2) + uvr(3) - uvr(4)
         if (status.eq.0) then
           do iv=to_uvr(4),to_uvr(3)
             do iu=to_uvr(1),to_uvr(2)
               i = iuvmap2(map_minirt,uv_pix)
               from_pix(1) = iu - to_uvr(1) + uvr(1)
               from_pix(2) = iv - to_uvr(4) + uvr(4)
               j = iuvmap2(map_minirt,from_pix)
               map_array(ip_edit+i-1) = map_array(ip_edit+j-1)
             end do
           end do
         end if
         call cmd_err( status,'Copy-Region','Failed' )

       else if (chr_cmatch('copy-row',liscom(icom))) then
         do i=1,8
           minirt(i) = map_minirt(i)
         enddo
         call plot_getrow2(map_minirt,'From-row : ','*',
     *                    uv_pos(2),status)
         call plot_getrow2(map_minirt,'To-row : ','*',
     *                    to_pos(2),status)
         uv_pix(1) = nint(uv_pos(1))
         uv_pix(2) = nint(uv_pos(2))
         to_pix(1) = nint(to_pos(1))
         to_pix(2) = nint(to_pos(2))
         if (status.eq.0) then
           do iu=uvr(1),uvr(2)
              to_pix(1) = iu
              i = iuvmap2(map_minirt,to_pix)
              j = iuvmap2(map_minirt,uv_pix)
              map_array(ip_edit+i-1) = map_array(ip_edit+j-1)
           end do
         end if
         call cmd_err( status,'Copy-Row','Failed' )

       else if (chr_cmatch('copy-column',liscom(icom))) then
         do i=1,8
           minirt(i) = map_minirt(i)
         enddo
         call plot_getcol2(map_minirt,'From-column : ','*',
     *                    uv_pos(1),status)
         call plot_getcol2(map_minirt,'To-column : ','*',
     *                    to_pos(1),status)
         uv_pix(1) = nint(uv_pos(1))
         uv_pix(2) = nint(uv_pos(2))
         to_pix(1) = nint(to_pos(1))
         to_pix(2) = nint(to_pos(2))
         if (status.eq.0) then
           do iv=uvr(3),uvr(4),-1
              to_pix(2) = iv
              i = iuvmap2(map_minirt,to_pix)
              j = iuvmap2(map_minirt,uv_pix)
              map_array(ip_edit+i-1) = map_array(ip_edit+j-1)
           end do
         end if
         call cmd_err( status,'Copy-Column','Failed' )

       else if (chr_cmatch('copy-from-image',liscom(icom))) then
         call dpredt( rt, status )
         call mapcat_getmap('Map-entry : ','default_map',
     *                      'READ',i,status)
         call map_alloc_in(i,'DIRECT',map_array,ip_map,status)
         call enminirt( minirt, status )
         call map_end_alloc(i,map_array,status)
         do i=1,4
           from_uvr(i) = minirt(i)
         enddo
         call plot_getuv2(minirt,'From-UV-region : ','*',
     *                    from_uvr,status)
         call plot_getpos2(map_minirt,'To-BLC : ','*',to_pos,status)
         to_pix(1) = nint(to_pos(1))
         to_pix(2) = nint(to_pos(2))
         to_uvr(1) = to_pix(1)
         to_uvr(2) = to_pix(1) + from_uvr(2) - from_uvr(1)
         to_uvr(4) = to_pix(2)
         to_uvr(3) = to_pix(2) + from_uvr(3) - from_uvr(4)
         if (status.eq.0) then
           do iv=to_uvr(3),to_uvr(4),-1
             do iu=to_uvr(1),to_uvr(2)
               i = iuvmap2(map_minirt,uv_pix)
               from_pix(1) = iu - to_uvr(1) + from_uvr(1)
               from_pix(2) = iv - to_uvr(4) + from_uvr(4)
               j = iuvmap2(minirt,from_pix)
               map_array(ip_edit+i-1) = map_array(ip_map+j-1)
             end do
           end do
         end if
         call ldredt( rt, status )
         call cmd_err( status,'Copy-From-Image','Failed' )

       else if (chr_cmatch('select-value-mode',liscom(icom))) then
         call io_getr('Replacement-value : ','*',fixed,status)
         if (status.eq.0) then
           replacement_mode = 2
           add_mode = 0
         endif
         call cmd_err( status,'Select-Value-Mode','Failed' )

       else if (chr_cmatch('select-scale-mode',liscom(icom))) then
         call io_getr('Scale : ','*',scale,status)
         call io_getr('Zero-level : ','*',zero,status)
         if (status.eq.0) then
           replacement_mode = 3
           add_mode = 0
         endif
         call cmd_err( status,'Select-Scale-Mode','Failed' )

       else if (chr_cmatch('select-noise-mode',liscom(icom))) then
         call io_getr('Noise-mean : ','*',mean,status)
         call io_getr('Noise-SD : ','*',SD,status)
         if (status.eq.0) then
           replacement_mode = 1
           add_mode = 1
         endif
         call util_rninit( 0 )
         call cmd_err( status,'Select-Noise-Mode','Failed' )

       else if (chr_cmatch('select-blanking-mode',liscom(icom))) then
         if (status.eq.0) then
           replacement_mode = 0
           add_mode = 0
         endif
         call cmd_err( status,'Select-Blanking-Mode','Failed' )

       else if (chr_cmatch('select-filter-mode',liscom(icom))) then
         option_list(1) ='linear . linear filter'
         option_list(2) ='log .... natural logarithm filter'
         option_list(3) ='ln ..... natural logarithm filter'
         option_list(4) ='log10 .. base10 logarithm filter'
         option_list(5) ='lg ..... base10 logarithm filter'
         option_list(6) ='exp .... exponential filter'
         option_list(7) ='10 ..... power-of-ten filter'
         option_list(8) ='sqrt ... square root filter'
         option_list(9) ='1/x .... reciprocal'
         option_list(10)='x^2 .... square filter'
         option_list(11)='binary . binary filter'
         option_list(12)='gate ... gating filter'
         call io_getopt('Filter-option (?=help) : ','linear',
     *                   option_list,11,option,status)
         if (chr_cmatch('linear',option)) then
            replacement_mode = 4
            add_mode = 0
            call io_getr('Scale-factor : ','1.0',scale,status)
            call io_getr('Zero-level : ','0.0',zero,status)
         elseif (chr_cmatch('log10',option) .or.
     *           chr_cmatch('lg',option)) then
            replacement_mode = 4
            add_mode = 2
         elseif (chr_cmatch('log',option) .or.
     *           chr_cmatch('ln',option)) then
            replacement_mode = 4
            add_mode = 1
         elseif (chr_cmatch('exp',option)) then
            replacement_mode = 4
            add_mode = 3
         elseif (chr_cmatch('10',option)) then
            replacement_mode = 4
            add_mode = 4
         elseif (chr_cmatch('sqrt',option)) then
            replacement_mode = 4
            add_mode = 5
         elseif (chr_cmatch('x^2',option)) then
            replacement_mode = 4
            add_mode = 6
         elseif (chr_cmatch('1/x',option)) then
            replacement_mode = 4
            add_mode = 7
         elseif (chr_cmatch('binary',option)) then
            replacement_mode = 4
            add_mode = 20
            call io_getr('Gate-low : ','0.0',gate_1,status)
            call io_getr('Gate-high : ','0.0',gate_2,status)
         elseif (chr_cmatch('gate',option)) then
            replacement_mode = 4
            add_mode = 21
            call io_getr('Gate-low : ','0.0',gate_1,status)
            call io_getr('Gate-high : ','0.0',gate_2,status)
            fixed = blank
            call io_getr('Replacement [blank] : ',' ',fixed,status)
         endif
         call cmd_err( status,'Select-Filter-Mode','Failed' )

       else if (chr_cmatch('define-blank',liscom(icom))) then
         call io_getr('Blank-value : ','*',blank_new,status)
         do i=1,map_minirt(5)*map_minirt(6)
           if (map_array(ip_edit+i-1).eq.blank) then
             map_array(ip_edit+i-1) = blank_new
           endif
         enddo
         blank = blank_new
         call cmd_err( status,'Define-Blank','Failed' )

       else if (chr_cmatch('reset-blank-values',liscom(icom))) then
         call io_getr('replacement-value : ','*',blank_new,status)
         do i=1,map_minirt(5)*map_minirt(6)
           if (map_array(ip_edit+i-1).eq.blank) then
             map_array(ip_edit+i-1) = blank_new
           endif
         enddo
         call cmd_err( status,'Reset-Blank-Values','Failed' )

       elseif (chr_cmatch('apply-ricean-correction',liscom(icom))) then
         call io_getr('Noise-level : ','0.0',y,status)
         if (status.eq.0 .and. y.gt.0.0) then
           do i=1,map_minirt(5)*map_minirt(6)
             if ( map_array(ip_edit+i-1).ne.blank .and.
     *            map_array(ip_edit+i-1).gt.0.0 .and.
     *            status.eq.0 ) then
                x = map_array(ip_edit+i-1)/y
                map_array(ip_edit+i-1)=y*image_polcorr(x,status)
             endif
           end do
         endif
         call cmd_err( status,'Apply-Ricean-Correction','Failed' )

       else if (chr_cmatch('mask-map',liscom(icom))) then
         call mapcat_getmap('Map-to-mask : ','default_map',
     *                    'READ',i,status)
         call map_alloc_toout(i,'DIRECT',map_array,
     *                        imapo,ip_map,status)
         call enminirt(minirt,status)
         do iv=min(map_minirt(4),minirt(4)),
     *         max(map_minirt(3),minirt(3)), -1
           do iu=max(map_minirt(1),minirt(1)),
     *           min(map_minirt(2),minirt(2))
             i = iuvmap2(minirt,uv_pix)
             j = iuvmap2(map_minirt,uv_pix)
             map_array(ip_map+i-1) =
     *         map_array(ip_map+i-1) * map_array(ip_edit+j-1)
           enddo
         enddo
         call map_end_alloc(imapo,map_array,status)
         call cmd_err( status,'Mask-Map','Failed' )

       else if (chr_cmatch('function',liscom(icom))) then
         call io_getwrd('Function (f(x,y)) : ','sin(x)*sin(y)',
     *                  function,lf,status)
         function = function(1:lf)//char(0)
         do i=1,4
           uvr(i) = map_minirt(i)
         enddo
         call plot_getuv2(map_minirt,'UV-region : ','*',uvr,status)
         i = 0
         call io_geti('Mode (0=replace; 1=add; 2=multiply) : ','0',
     *                i,status)
         if (i.lt.0) then
           i = 0
         elseif (i.gt.2) then
           i = 2
         endif
         if (status.eq.0) then
           call eval_array(function,i,map_minirt(1),map_minirt(3),
     *                     uvr(1),uvr(2),uvr(3),uvr(4),
     *                     map_minirt(5),map_minirt(6),
     *                     map_array(ip_edit))
         endif

       else if (chr_cmatch('edit-options',liscom(icom))) then
         option_list(1)='auto-discard-on .. auto discard on error on'
         option_list(2)='auto-discard-off . auto discard on error off'
         option_list(3)='set-map-prompt ... prompt for set map command'
         call io_getopt('Edit-option (?=help) : ','auto-discard-on',
     *                   option_list,3,option,status)
         if (chr_cmatch('auto-discard-on',option)) then
            edit_mode = 1
         elseif (chr_cmatch('auto-discard-off',option)) then
            edit_mode = 0
         elseif (chr_cmatch('set-map-prompt',option)) then
            call io_getstr('Set-Map-Prompt : ','Catalogue-Entry',
     *                     sm_prompt,status)
            if (status.ne.0) then
               sm_prompt = ' '
            endif
         endif
         call cmd_err( status,'Edit-Options','Failed' )

       end if
       cdata(1) = 100
       call dpredt( rt, status )
       if (status.ne.0 .and.  edit_mode.eq.1) then
         call map_end_alloc( iedit, map_array, status )
         iedit = -1
         edit_mode = 0
         sm_prompt = ' '
       endif

       end
C
C
       real*4 function imed_value( val )
C      ---------------------------------
C
C Return a replacement value for an image pixel
C
C Given:
C   value at pixel
       real*4       val
C-

C control data for the editing
       integer                  imap, iedit, ip_edit, replacement_mode,
     *                          add_mode, map_minirt(8), edit_mode
       real*4                   blank, fixed, SD, mean, scale, zero,
     *                          gate_1, gate_2

       common /save_image_edit/ imap, iedit, ip_edit, replacement_mode,
     *                          add_mode, blank, fixed, SD, mean,
     *                          scale, zero, map_minirt, edit_mode,
     *                          gate_1, gate_2

       real*4                   max_val, max_val10
       real*8                   util_rnnorm

       max_val = log(1.0E35)
       max_val10 = log10(1.0E35)

       if (replacement_mode.eq.4) then
         if (val.eq.blank) then
            imed_value = val
         else
           if (add_mode.eq.0) then
              imed_value = (val-zero)*scale
           elseif (add_mode.eq.1) then
              if (val.le.0.0) then
                 imed_value = blank
              else
                 imed_value = log(val)
              endif
           elseif (add_mode.eq.2) then
              if (val.le.0.0) then
                 imed_value = blank
              else
                 imed_value = log10(val)
              endif
           elseif (add_mode.eq.3) then
              if (val.le.max_val) then
                imed_value = exp(val)
              else
                imed_value = blank
              endif
           elseif (add_mode.eq.4) then
              if (val.le.max_val10) then
                imed_value = 10.0**(val)
              else
                imed_value = blank
              endif
           elseif (add_mode.eq.5) then
              if (val.le.0.0) then
                 imed_value = blank
              else
                 imed_value = sqrt(val)
              endif
           elseif (add_mode.eq.6) then
              imed_value = imed_value * imed_value
           elseif (add_mode.eq.7) then
              if (val.eq.0.0) then
                 imed_value = blank
              else
                 imed_value = 1.0/val
              endif
           elseif (add_mode.eq.20) then
              if (val.lt.gate_1 .or. val.gt.gate_2) then
                 imed_value = 0.0
              else
                 imed_value = 1.0
              endif
           elseif (add_mode.eq.21) then
              if (val.lt.gate_1 .or. val.gt.gate_2) then
                 imed_value = fixed
              else
                 imed_value = val
              endif

           endif
         endif

       elseif (replacement_mode.eq.3) then
          imed_value = (val-zero)*scale

       else
         if (replacement_mode.eq.2) then
           imed_value = fixed
         elseif (replacement_mode.eq.1) then
           imed_value = util_rnnorm(mean,SD)
         else
           imed_value = blank
         endif
         if (add_mode.eq.1) imed_value = imed_value + val
       endif

       end


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine cselac ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Consumption of electron acceptors (new, generic!)

!
!     Description of the module :
!
!     General water quality module for DELWAQ:
!     The electron acceptors considered are dissolved oxygen,
!     nitrate, sulphate and carbon monoxide (org. matter).
!     The mineralisation fluxes of orgnaic matter fractions are added.
!     The consumption fluxes follow from the total mineralisation flux
!     and the relative contributions of the electron acceptors.
!     The relative consumptions of electron-acceptors O2, NO3, SO4 and
!     carbon monoxide (organic matter) are computed on the basis of
!     MM-kinetics for limitation and inhibition. The reduction of carbon
!     monoxide from organic matter results in methanogenesis.
!     The process is valid for overlying water as well as sediment.
!
!        ----- description of parameters -----
! Name    T   L I/O   Description                                 Units
! ----    --- -  -    -------------------                          ----
! CFEA    R*4 1 I particulate amorphous oxidizing iron          [gFe/m3]
! CNI     R*4 1 I concentration of nitrate                       [gN/m3]
! CNIC    R*4 1 I critical nitrate conc. for inh. methanogen.    [gN/m3]
! COX     R*4 1 I dissolved oxygen concentration                  [g/m3]
! COXC1   R*4 1 I critical diss. ox. conc. for deniftrif.         [g/m3]
! COXC2   R*4 1 I critical diss. ox. conc. for inh. iron. red.    [g/m3]
! COXC3   R*4 1 I critical diss. ox. conc. for inh. sulph. red.   [g/m3]
! COXC4   R*4 1 I critical diss. ox. conc. for inh. methanogen.   [g/m3]
! CSU     R*4 1 I concentration of sulphate                      [gS/m3]
! CRTEMP  R*4 1 I critical temp. for denitr., sulphate red., meth.  [oC]
! DELT    R*4 1 I computational timestep                             [d]
! FCT2    R*4 1 I reduction factor for denitr. below crit. temp.    [oC]
! FCT3    R*4 1 I red. factor for iron red. below crit. temp.       [oC]
! FCT4    R*4 1 I red. factor for sulphate red. below crit. temp.   [oC]
! FCT5    R*4 1 I reduction factor for methanog. below crit. temp.  [oC]
! FDEN    R*4 1 I reduction factor for denitr. below crit. temp.    [oC]
! FIRED   R*4 1 I red. factor for iron red. below crit. temp.       [oC]
! FSRED   R*4 1 I red. factor for sulphate red. below crit. temp.   [oC]
! FMET    R*4 1 I reduction factor for methanog. below crit. temp.  [oC]
! FL (1)  R*4 1 O mineralisation flux for oxygen consumption   [gC/m3/d]
! FL (2)  R*4 1 O mineralisation flux for denitrification      [gC/m3/d]
! FL (3)  R*4 1 O mineralisation flux for sulphate reduction   [gC/m3/d]
! FL (4)  R*4 1 O mineralisation flux for methanogenesis       [gC/m3/d]
! FOX     R*4 1 L unscaled relative contribution of DO cons.         [-]
! FOX20   R*4 1 L unscaled relative contribution of DO cons. at 20oC [-]
! FROX    R*4 1 L scaled relative contribution of DO cons.           [-]
! FROXC   R*4 1 O corrected fractional oxygen contribution           [-]
! FNI     R*4 1 L unscaled relative contribution of denitrification  [-]
! FNI20   R*4 1 L unscaled relative contribution of denitr. at 20 oC [-]
! FRNI    R*4 1 L scaled relative contribution of denitrification    [-]
! FRNIC   R*4 1 O corrected fractional nitrate contribution          [-]
! FFE20   R*4 1 L unscaled relative contribution of iron re. at 20 oC[-]
! FFE     R*4 1 L unscaled relative contribution of iron reduction   [-]
! FRFE    R*4 1 L scaled relative contribution of iron reduction     [-]
! FRFEC   R*4 1 O corrected fractional iron contribution             [-]
! FSU     R*4 1 L unscaled relative contribution of sulph. reduction [-]
! FSU20   R*4 1 L unscaled relative contr. of sulph. red. at 20 oC   [-]
! FRSU    R*4 1 L scaled relative contribution of sulph. reduction   [-]
! FRSUC   R*4 1 O corrected fractional sulphate contribution         [-]
! FCH4    R*4 1 L unscaled relative contribution of methanogenesis   [-]
! FCH420  R*4 1 L unscaled relative contr. of methanog. at 20 oC     [-]
! FRCH4   R*4 1 L scaled relative contribution of methanogenesis     [-]
! FRCH4C  R*4 1 O corrected fractional methane contribution          [-]
! FSUM    R*4 1 L sum of unscaled relative contributions             [-]
! FRNI    R*4 1 O scaled relative contribution of nitrate            [-]
! KSOX    R*4 1 I half saturation constant for DO limitation      [g/m3]
! KSNI    R*4 1 I half saturation constant for NI limitation     [gN/m3]
! KSSU    R*4 1 I half saturation constant for SU limitation     [gS/m3]
! KSOXI   R*4 1 I half saturation constant for inhibition by DO   [g/m3]
! KSNISUI R*4 1 I half saturation constant for inhibition by NI  [gN/m3]
! KSSUI   R*4 1 I half saturation constant for inhibition by SU  [gS/m3]
! KTDEN   R*4 1 I temperature coefficient for denitrifcation         [-]
! KTMET   R*4 1 I temperature coefficient for methanogenesis         [-]
! KTMIN   R*4 1 I temperature coefficient for aerobic mineralisation [-]
! KTIRED  R*4 1 I temperature coefficient for iron reduction         [-]
! KTSRED  R*4 1 I temperature coefficient for sulphate reduction     [-]
! POROS   R*4 1 I porosity                                           [-]
! RDEN    R*4 1 L proposed mineralisation rate for denitrif.   [gC/m3/d]
! RDMAX   R*4 1 L maximal mineralisation rate for denitrif.    [gC/m3/d]
! RIRED   R*4 1 L proposed mineral. rate for iron red.         [gC/m3/d]
! RSRED   R*4 1 L proposed mineral. rate for sulphate red.     [gC/m3/d]
! RIMAX   R*4 1 L maximal mineral. rate for iron red.          [gC/m3/d]
! RSMAX   R*4 1 L maximal mineral. rate for sulphate red.      [gC/m3/d]
! RMIN1   R*4 1 I mineralisation flux of POC1                  [gC/m3/d]
! RMIN2   R*4 1 I mineralisation flux of POC2                  [gC/m3/d]
! RMIN3   R*4 1 I mineralisation flux of POC3                  [gC/m3/d]
! RMIN4   R*4 1 I mineralisation flux of POC4                  [gC/m3/d]
! RMIN5   R*4 1 I mineralisation flux of POC5                  [gC/m3/d]
! RMIN6   R*4 1 I mineralisation flux of DOC                   [gC/m3/d]
! RTMIN   R*4 1 I total mineralisation flux                    [gC/m3/d]
! TEMP    R*4 1 I ambient temperature                               [oC]
! TEMPC1  R*4 1 L ambient temp. corr. function for aerobic mineral.  [-]
! TEMPC2  R*4 1 L ambient temp. corr. function for denitrification   [-]
! TEMPC3  R*4 1 L ambient temp. corr. function for iron red.         [-]
! TEMPC4  R*4 1 L ambient temp. corr. function for sulphate red.     [-]
! TEMPC5  R*4 1 L ambient temp. corr. function for methanogenesis    [-]
! TEMP20  R*4 1 L ambient temperature - stand. temp (20)            [oC]
!
!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------
!
      IMPLICIT NONE
!
      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT(43) , INCREM(43) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
      INTEGER  IP(43)
      INTEGER  IN(43)
      INTEGER  IFLUX  , ISEG   , IKMRK1, ILUMON
!
      REAL     COX    , CNI    , CFEA   , CSU    , CCH4
      REAL     RMIN1  , RMIN2  , RMIN3  , RMIN4  , RTMIN  , RDEN   ,
     +         RSRED  , RDMAX  , RSMAX  , DELT   , RMIN5  , RMIN6
      REAL     FOX    , FNI    , FSU    , FCH4   , FOX20  , FNI20  ,
     +         FSU20  , FCH420 , FSUM   , FROX   , FRNI   , FRSU   ,
     +         FRCH4  , FROXC  , FRNIC  , FRSUC  , FRCH4C , FRMCH4
      REAL     KSOX   , KSOXI  , KSNI   , KSNISUI, KSSU   , KSSUI  ,
     +         KTMIN  , KTDEN  , KTSRED , KTMET  , FCT2   , FCT3   ,
     +         FCT4   , FDEN   , FIRED  , FSRED  , FMET   , COXC1  ,
     +         COXC2  , COXC3  , COXC4  , CNIC   , KSFE   , KSNIFEI
      REAL     KTIRED , FRFEC  , FCT5   , RIRED  , RIMAX  , FFE20  ,
     +         FFE    , FRFE
      REAL     POROS  , TEMP   , TEMPC1 , TEMPC2 , TEMPC3 , TEMPC4 ,
     +         TEMPC5 , CRTEMP , TEMP20
      REAL     OXC_RATIO
      REAL     NIC_RATIO
      REAL     FEC_RATIO
      REAL     SUC_RATIO
      REAL     CHC_RATIO
      REAL     ROMAX
      REAL     ROXC
      LOGICAL  FIRST, ONLY_OX
      SAVE     FIRST, ONLY_OX
      DATA     FIRST /.TRUE./
!
      CALL GETMLU(ILUMON)
!
      IN = INCREM
      IP = IPOINT
!
!     -----Warnings-----
!
      IF (FIRST) THEN
          IF (PMSA(IP(11)).LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsOxCon should be greater than zero'
          ELSEIF (PMSA(IP(12)).LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsNiDen should be greater than zero'
          ELSEIF (PMSA(IP(13)).LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsFeRed should be greater than zero'
          ELSEIF (PMSA(IP(14)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsSuRed should be greater than zero'
          ELSEIF (PMSA(IP(15)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsOxDen should be greater than zero'
          ELSEIF (PMSA(IP(16)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsNiIRdInh should be greater than zero'
          ELSEIF (PMSA(IP(17)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsNiSRdInh should be greater than zero'
          ELSEIF (PMSA(IP(18)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : half saturation constant',
     +                          ' KsSuMet should be greater than zero'
          ELSEIF (PMSA(IP(35)) .LE. 0.0) THEN
              WRITE (ILUMON, *) 'WARNING : Poros, PORS1 or PORS2',
     +                          ' should be greater than zero'
          ENDIF
          IF (PMSA(IP(38)) .GT. 0.5) THEN
            ONLY_OX = .TRUE.
          ELSE
            ONLY_OX = .FALSE.
          ENDIF
          FIRST = .FALSE.
      ENDIF
!
!     Do the segment loop.
!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF ( IKMRK1 .GT. 0 ) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
!
!           Read input. Adjust concentrations to zero, when negative.
!           Adjust half saturation const. to prevent division by zero.
!
            COX    = MAX (0.0 , PMSA(IP(1)) )
            CNI    = MAX (0.0 , PMSA(IP(2)) )
            CFEA   = MAX (0.0 , PMSA(IP(3)) )
            CSU    = MAX (0.0 , PMSA(IP(4)) )
            RMIN1  = PMSA(IP(5 ))
            RMIN2  = PMSA(IP(6 ))
            RMIN3  = PMSA(IP(7 ))
            RMIN4  = PMSA(IP(8 ))
            RMIN5  = PMSA(IP(9 ))
            RMIN6  = PMSA(IP(10))
            KSOX   = MAX (1.0E-06 , PMSA(IP(11)) )
            KSNI   = MAX (1.0E-06 , PMSA(IP(12)) )
            KSFE   = MAX (1.0E-06 , PMSA(IP(13)) )
            KSSU   = MAX (1.0E-06 , PMSA(IP(14)) )
            KSOXI  = MAX (1.0E-06 , PMSA(IP(15)) )
            KSNIFEI= MAX (1.0E-06 , PMSA(IP(16)) )
            KSNISUI= MAX (1.0E-06 , PMSA(IP(17)) )
            KSSUI  = MAX (1.0E-06 , PMSA(IP(18)) )
            KTMIN  = PMSA(IP(19))
            KTDEN  = PMSA(IP(20))
            KTIRED = PMSA(IP(21))
            KTSRED = PMSA(IP(22))
            KTMET  = PMSA(IP(23))
            FDEN   = PMSA(IP(24))
            FIRED  = PMSA(IP(25))
            FSRED  = PMSA(IP(26))
            FMET   = PMSA(IP(27))
            COXC1  = PMSA(IP(28))
            COXC2  = PMSA(IP(29))
            COXC3  = PMSA(IP(30))
            COXC4  = PMSA(IP(31))
            CNIC   = PMSA(IP(32))
            CRTEMP = PMSA(IP(33))
            TEMP   = PMSA(IP(34))
            POROS  = PMSA(IP(35))
            DELT   = PMSA(IP(36))
            FRMCH4 = PMSA(IP(37))
!
!           Calculate the sum of the mineralisation fluxes
!
            RTMIN = RMIN1 + RMIN2 + RMIN3 + RMIN4 + RMIN5 + RMIN6

            IF (ONLY_OX) THEN
              FROXC = 1.
              FRNIC = 0.
              FRFEC = 0.
              FRSUC = 0.
              FRCH4C = 0.

            ELSE
!
!           Calculation of the temperature dependency coefficients
!
            IF ( TEMP .GE. CRTEMP ) THEN
                  FCT2 = 1.0
                  FCT3 = 1.0
                  FCT4 = 1.0
                  FCT5 = 1.0
            ELSE
                  FCT2 = FDEN
                  FCT3 = FIRED
                  FCT4 = FSRED
                  FCT5 = FMET
            ENDIF
!
            TEMP20 = TEMP - 20.0
            TEMPC1 = KTMIN ** TEMP20
            TEMPC2 = FCT2 * KTDEN ** TEMP20
            TEMPC3 = FCT3 * KTIRED ** TEMP20
            TEMPC4 = FCT4 * KTSRED ** TEMP20
            TEMPC5 = FCT5 * KTMET ** TEMP20
!
!           Calculation of the unscaled (relative) contributions
!
            FOX20  = COX / (KSOX * POROS + COX)
!
            FNI20  = ( CNI / (KSNI * POROS + CNI) ) *
     +               ( 1 - COX / (KSOXI * POROS + COX) )
!
            FFE20  = ( CFEA / (KSFE * POROS + CFEA) ) *
     +               ( 1 - CNI / (KSNIFEI * POROS + CNI) )
!
            FSU20  = ( CSU / (KSSU * POROS + CSU) ) *
     +               ( 1 - CNI / (KSNISUI * POROS + CNI) )
!
            FCH420 = 1 - CSU / (KSSUI * POROS + CSU)
!
!           Adjust for temperature dependency.
!
            FOX    = FOX20  * TEMPC1
            FNI    = FNI20  * TEMPC2
            FFE    = FFE20  * TEMPC3
            FSU    = FSU20  * TEMPC4
            FCH4   = FCH420 * TEMPC5
!
!           Correction of the unscaled contributions for too high
!           dissolved oxygen or nitrate concentrations to allow
!           sulphate reduction or methanogenesis.
!
            IF ( COX .GE. (COXC1*POROS) )  FNI = 0.0
            IF ( COX .GE. (COXC2*POROS) )  FFE = 0.0
            IF ( COX .GE. (COXC3*POROS) )  FSU = 0.0
            IF ( COX .GE. (COXC4*POROS) .OR.
     +           CNI .GE. (CNIC*POROS) )  FCH4 = 0.0
!
!           Calculation of the scaled contributions
!
            FSUM  = FOX + FNI + FFE + FSU + FCH4
            FROX  = FOX / FSUM
            FRNI  = FNI / FSUM
            FRFE  = FFE / FSUM
            FRSU  = FSU / FSUM
            FRCH4 = 1 - (FROX + FRNI + FRFE + FRSU)
!
!           Calculate the maximal and proposed consumption fluxes in Carbon equivalents of
!           the electron acceptors oxygen, nitrate and sulphate
!           use a safety margin 0.5 on oxygen 0.9 on the rest
!
            OXC_RATIO = 2.667
            NIC_RATIO = 0.933
            FEC_RATIO = 18.67
            SUC_RATIO = 1.333
            CHC_RATIO = 0.5
            ROMAX = COX / OXC_RATIO / DELT * 0.5
            RDMAX = CNI / NIC_RATIO / DELT * 0.9
            RIMAX = CFEA / FEC_RATIO / DELT * 0.9
            RSMAX = CSU / SUC_RATIO / DELT * 0.9
!
!           Correct scaled contributions for availability of electron
!           acceptors nitrate, oxygen, iron and sulphate
!
            RDEN  = FRNI  * RTMIN
            IF ( RDEN .GT. RDMAX .AND. RDEN .GT. 0.0 ) THEN
                   FRNIC = FRNI * RDMAX / RDEN
                   FROX  = FROX + FRNI - FRNIC
            ELSE
                   FRNIC = FRNI
            ENDIF
!
            ROXC  = FROX  * RTMIN
            IF ( ROXC .GT. ROMAX .AND. ROXC .GT. 0.0 ) THEN
                   FROXC = FROX * ROMAX / ROXC
                   FRFE  = FRFE + FROX - FROXC
            ELSE
                   FROXC = FROX
            ENDIF
!
            RIRED  = FRFE  * RTMIN
            IF ( RIRED .GT. RIMAX .AND. RIRED .GT. 0.0 ) THEN
                   FRFEC = FRFE * RIMAX / RIRED
                   FRSU  = FRSU + FRFE - FRFEC
            ELSE
                   FRFEC = FRFE
            ENDIF
!
            RSRED  = FRSU  * RTMIN
            IF ( RSRED .GT. RSMAX .AND. RSRED .GT. 0.0 ) THEN
                   FRSUC = FRSU * RSMAX / RSRED
            ELSE
                   FRSUC = FRSU
            ENDIF
!
            FRCH4C = 1 - (FROXC + FRNIC + FRFEC + FRSUC)

!           endif ONLY_OX
            ENDIF
!
!           Calculate the electron acceptor consumption fluxes
!
            FL( 1+IFLUX ) = FROXC  * RTMIN
            FL( 2+IFLUX ) = FRNIC  * RTMIN
            FL( 3+IFLUX ) = FRFEC  * RTMIN
            FL( 4+IFLUX ) = FRSUC  * RTMIN
            FL( 5+IFLUX ) = FRCH4C * FRMCH4 * RTMIN
            FL( 6+IFLUX ) = FRCH4C * (1.-FRMCH4) * RTMIN
!
!           The corrected scaled contributions are output
!
            PMSA(IP(39)) = FROXC
            PMSA(IP(40)) = FRNIC
            PMSA(IP(41)) = FRFEC
            PMSA(IP(42)) = FRSUC
            PMSA(IP(43)) = FRCH4C
!
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP   = IP   + IN
!
 9000 CONTINUE
!
      RETURN
!
      END


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:44 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE OCEANSTEP__genmod
          INTERFACE
            SUBROUTINE OCEANSTEP(PICEC,PICED,PHEAT,PPME,PROFF,PTAUX,    &
     &PTAUY,PUST3,PSNOW,PSST,PMLD,PIFLUX,PCLICED,NGENIE)
              REAL(KIND=8) :: PICEC(2048)
              REAL(KIND=8) :: PICED(2048)
              REAL(KIND=8) :: PHEAT(2048)
              REAL(KIND=8) :: PPME(2048)
              REAL(KIND=8) :: PROFF(2048)
              REAL(KIND=8) :: PTAUX(2048)
              REAL(KIND=8) :: PTAUY(2048)
              REAL(KIND=8) :: PUST3(2048)
              REAL(KIND=8) :: PSNOW(2048)
              REAL(KIND=8) :: PSST(2048)
              REAL(KIND=8) :: PMLD(2048)
              REAL(KIND=8) :: PIFLUX(2048)
              REAL(KIND=8) :: PCLICED(2048)
              INTEGER(KIND=4) :: NGENIE
            END SUBROUTINE OCEANSTEP
          END INTERFACE
        END MODULE OCEANSTEP__genmod