subroutine tsource(j,m) c c======================================================================= c === c This routine computes the tracers source term Tsrc at row J and === c for tracer M. === c === c Calls: ERRIO, EXITUS, LENGTH, NO_DIGIT === c === c======================================================================= c c----------------------------------------------------------------------- c Define global data. c----------------------------------------------------------------------- c #include #include #include #include #include #if defined pttrcsrc & defined rivsrc # include # include # include # include # include #endif c c----------------------------------------------------------------------- c Define local data. c----------------------------------------------------------------------- c integer j,m #if defined pttrcsrc & defined rivsrc c integer icard,idum,ios,k,kmsrc,n,sbgn,send,slen integer no_digit logical badpt,first FLOAT * tau,val character*17 mess character*80 fmt c save badpt,first c data badpt,first /.false.,.true./ #endif c c======================================================================= c Begin executable code. c======================================================================= c #if defined pttrcsrc & defined rivsrc c----------------------------------------------------------------------- c Read in source terms. c----------------------------------------------------------------------- c if (first) then c c Open tracer point source file. c call length (tsrcnam,slen,sbgn,send) if (slen.lt.1) then write(stdout,900) call exitus('TSOURCE') end if c open (tsrcinp, file=tsrcnam(sbgn:send), form='formatted', & status='old', iostat=ios) if (ios.ne.0) then write(stdout,910) tsrcnam(sbgn:send) call exitus('TSOURCE') end if c c Read tracer point source file. c ntsrc = 0 read (tsrcinp,*,iostat=ios) icard c do 10 while ( (icard.ge.0) .and. (ios.eq.0) ) c if (icard.gt.0) then c ntsrc = ntsrc + 1 if (ntsrc.le.mxsrc) then read (tsrcinp,*,iostat=ios) itsrc(ntsrc),jtsrc(ntsrc), & mtsrc(ntsrc),tsrcf(ntsrc), & facsrc(ntsrc),tausrc(ntsrc),tsrcd(ntsrc), & tsrcf_i(ntsrc),tausrc_i(ntsrc) else read (tsrcinp,*,iostat=ios) idum end if c if ((ios.eq.0).and.(ntsrc.le.mxsrc)) then c c Check source location. c if ((itsrc(ntsrc).lt.1).or.(itsrc(ntsrc).gt.imt).or. & (jtsrc(ntsrc).lt.2).or.(jtsrc(ntsrc).gt.jmtm2)) & then write (stdout,920) ntsrc,itsrc(ntsrc),jtsrc(ntsrc), & 1,imt,2,jmtm2 badpt = .true. end if c c Check source identifier. c if ((mtsrc(ntsrc).lt.1).or.(mtsrc(ntsrc).gt.nt)) then write (stdout,930) ntsrc,mtsrc(ntsrc),1,nt badpt = .true. end if end if end if c read (tsrcinp,*,iostat=ios) icard c 10 continue c c Check number of points. c if (ntsrc.gt.mxsrc) then write (stdout,940) ntsrc,mxsrc end if c c Check I/O. c write (fmt,950) no_digit(ntsrc) write (mess,fmt) ntsrc call errio (stdout,'TSOURCE',mess,ios) c c Exit on errors. c if (badpt .or. (ntsrc.gt.mxsrc)) call exitus ('TSOURCE') c write(stdout,960) tsrcnam(sbgn:send) c first = .false. c end if c c----------------------------------------------------------------------- c Set source for additional tracers. c----------------------------------------------------------------------- c do 40 n=1,ntsrc if ( (mtsrc(n).eq.m) .and. (jtsrc(n).eq.j) ) then c kmsrc=1 do 20 while ( (tdepth(itsrc(n),kmsrc,0).lt.(m2cm*tsrcd(n))) & .and. (kmsrc.lt.km) ) kmsrc=kmsrc+1 20 continue c if (tdepth(itsrc(n),kmsrc,0).ge.(m2cm*tsrcd(n))) then do 30 k=1,kmsrc if (facsrc(n).gt.0) then if ( ttsec .lt. (facsrc(n)*tausrc_i(n)) ) then tau=c1/tausrc_i(n) if (m.eq.2) then val=tsrcf_i(n)-smean else val=tsrcf_i(n) endif else tau=c1/tausrc(n) if (m.eq.2) then val=tsrcf(n)-smean else val=tsrcf(n) endif end if c Tsrc(itsrc(n),k) = tau*(val-t(itsrc(n),k,m))+ & Tsrc(itsrc(n),k) else Tsrc(itsrc(n),k) = tsrcf(n)+Tsrc(itsrc(n),k) end if 30 continue else write (stdout,970) n,tdepth(itsrc(n),km,0)*cm2m, & tsrcd(n) badpt = .true. end if end if 40 continue c c Exit on errors. c if (badpt) call exitus ('TSOURCE') c #endif return #if defined pttrcsrc & defined rivsrc c 900 format (/'***Error: TSOURCE - invalid input file name, all ', & 'blanks.') 910 format (/'***Error: TSOURCE - could not open file:'/11x,1h",a, & 1h") 920 format (/'***Error: TSOURCE - invalid location for source ',i10/ & 11x,'(ITSRC,JTSRC) = ',i10,1x,i10/11x,'valid i-range = [', & i10,', ',i10,']'/11x,'valid j-range = [',i10,', ',i10,']') 930 format (/'***Error: TSOURCE - invalid tracer index for source ', & i10/11x,'MTSRC = ',i10/11x,'valid range = [',i10,', ',i10, & ']') 940 format (/'***Error: TSOURCE - excessive number of sources.'/11x, & 'NTSRC = ',i10/11x,'MXSRC = ',i10/11x,'Edit ctsrc.h,', & ' recompile and try again.') 950 format ('(',1h','reading source ',3h',i,i2.2,')') 960 format (/' TSOURCE - read river info from file:'/1x,1h",a,1h") 970 format (/'***Error: TSOURCE - excessive depth for tracer: ',i10/ & 11x,'Deepest model level: ',1pg15.8,' (m)'/ & 11x,'Requested source depth: ',1pg15.8,' (m)') c #endif end