C SUBROUTINE OUTPUT(isech) C **** WRITES A HISTORY FILE include "params.h" PARAMETER(IMAXG=ZIMX,JMAXG=ZJMX) PARAMETER(IMAXGP=IMAXG+1,JMAXGP=JMAXG+1) include "index.h" include "blnk.h" include "buff.h" include "cons.h" include "types.h" include "strt.h" include "tlib.h" include "unit.h" include "dynphi.h" include "sechis.h" real fsech(zimxp,zkmxp,mxfsech,2) ! auto array for sec hist data PARAMETER (NAURPX=55,NLEX=800) COMMON/AURDAT/ AURPS(NLEX,2,NAURPX), NPTS(NAURPX),IPR, NAURP, 1 PARAMV(NAURPX), JSWOLDA, JDITH, JDIDK COMMON /IONCR/ ISTAR,IHEM,THETA0(2),OFFA(2),OFFC(2),DSKOFA(2), 1 DSKOFC(2),PHID(2),PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2), 2 PHINM0(2),PSIM(2),PSIE(2),PCEN(2),R1(2) 3 ,DDUUMM(IMAXMP*JMX0+IMX0*JMX0+2) C 3, THETAC(2),R2(2) COMMON /OVALR/ RRAD(2),H0,RH,RROTH,E0,REE,RROTE,FC,ALFAC,FD,ALFAD 1, ALFK,ALF6,ALF21,RROT6,RROT21,RD6,RD6V,RD21,RH6,RH21,RT6,RT21 2, ALFA0,RALFA,ALFA20,RALFA2,E20,RE2 COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,COLFAC common/ingpi/ f107,f107a,ctpoten,hpower,byimf ! for getgpi DIMENSION RD354(354), ID46(46) C **** C **** THE FOLLOWING REPRESENTS THE HEADER AS IT WAS WRITTEN C **** AFTER 11/22/88 (I.E. HEAD(219+NAURP)= 4.3) C **** C CHARACTER*8 PMVC(38),THET0C(30), ROTC(33), MCF(4) C DATA ROTC /8HRROT ,8HRDISP ,8HH0 ,8HRH ,8HFC , C 2 8HALFAC ,8HFD ,8HALFAD ,8HE0 ,8HRE , C 3 8HALFK ,8HALF1 ,8HALF2 ,8HRAROT1 ,8HRAROT2 , C 4 8HRD1A ,8HRD1V ,8HRD2 ,8HRAH1 ,8HRAH2 , C 5 8HRAHT1 ,8HRAHT2 ,8HFALFC ,8HFALF6 ,8HFALF22 , C 6 8HALFA0 ,8HRALFA ,8HALFA20 ,8HRALFA2 ,8HE02 , C 7 8HRE2 ,8HRARADS ,8HRARADN / C **** C **** LAST FEW VALUES OF NAURP PARAMETERS C **** C 8 8HE1 ,8HE2 ,8HH1 ,8HH2 ,8HROT , C 9 8HFALFC ,8HFALF6 ,8HFALF22 ,8HALFA1 ,8HALFA2 / C **** C **** THE FOLLOWING REPRESENTS THE HEADER AS IT WAS WRITTEN C **** AFTER 3/13/89 (I.E. HEAD(219+NAURP)= 4.32) C **** CHARACTER*8 PMVC(38),THET0C(30), ROTC(30), MCF(4) DATA PMVC /'POWER ','CTPOTEN ','BYIMF ', 1 'R1 ','PHIDM ','PHIDP ','PHINM ','PHINP ', 2 'ARADPN ','ARADNS ','OFFAPN ','OFFANS ','DKOFAPN ', 3 'DKOFANS ','PHIDPN ','PHIDNS ','PHINPN ','PHINNS ', 4 'PCEPPN ','PCEPNS ','PCENPN ','PCENNS ','DC/DKCPN', 5 'DC/DKCNS','D/THETPN','D/THETNS','OFFCPN ','OFFCNS ', 6 'E1 ','E2 ','H1 ','H2 ','ROTE ', 7 'ROTH ','TWA6 ','TWA21 ','ALFA1 ','ALFA2 '/ DATA THET0C/ 'THETA0S ','THETA0N ','OFFAS ','OFFAN ', 1 'OFFCS ','OFFCN ','DSKOFAN ', 2 'DSKOFAS ','DSKOFCN ','DSKOFCS ','PHIDS ','PHIDN ', 3 'PHINS ','PHINN ','PHIDP0S ','PHIDP0N ','PHIDM0S ', 4 'PHIDM0N ','PHINP0S ','PHINP0N ','PHINM0S ','PHINM0N ', 5 'PSIMS ','PSIMN ','PSIES ','PSIEN ','PCENS ', 6 'PCENN ','R1S ','R1N '/ DATA ROTC /'RARADS ','RARADN ','RH0 ','RH ','RROTH ', 1 'E0 ','REE ','RROTE ','FC ','ALFAC ', 2 'FD ','ALFAD ','ALFK ','ALF6 ','ALF21 ', 3 'RROT6 ','RROT21 ','RD6 ','RD6V ','RD21 ', 4 'RH6 ','RH21 ','RT6 ','RT21 ','ALFA0 ', 5 'RALFA ','ALFA20 ','RALFA2 ','E02 ','RE2 '/ DATA MCF /'MOD NUM ','COLFAC ','F107 ','F107A '/ DIMENSION ISTARTM(3) EQUIVALENCE (INPT(103),ISTARTM) DIMENSION IHEAD(512),HEAD(512) EQUIVALENCE(IHEAD,HEAD) DATA IHEAD/512*0/ integer unlink dimension labhist(3,20) character*80 hvolinfo ! hist volume info for mss comment field character*80 mssvol ! mss path for volume being written (labhis) character*9 htype ! 'Primary ' or 'Secondary' character*8 chword(3),char8 data ncallprim/0/, ncallsec/0/ c if (isech.gt.0) then ! writing a secondary history (use /SECHIS/) ncallsec = ncallsec+1 ihisto = ihissech mhist = mhissech ifill = ifilsech mfill = mfilsech isave = isavsech msave = msavsech itape = itapsech mtape = mtapsech lbtape = lbsech labhist(:,:) = labsech(:,:) luhist = lusech hvolinfo = volinfo_sech idelmin = sechist(1)*24*60+sechist(2)*60+sechist(3) htype = 'Secondary' else ! writing full restart history (use /STRT/) ncallprim = ncallprim+1 ihisto = ihis mhist = mhis ifill = ifil mfill = mfil isave = isav msave = msav itape = itap mtape = mtap lbtape = lbtap labhist(:,:) = labhis(:,:) luhist = ihist hvolinfo = volinfo idelmin = inpt(112)*24*60+inpt(113)*60+inpt(114) htype = 'Primary ' endif do i=1,3 write(chword(i),"(a)") labhist(i,itape) enddo do i=1,80 mssvol(i:i) = ' ' enddo mssvol = '/'//chword(1)(1:len_trim(chword(1))) + //'/'//chword(2)(1:len_trim(chword(2))) + //'/'//chword(3)(1:len_trim(chword(3))) c c Load header: c IHEAD(1)=ITER X = ITER*C(4)+1.E-4 IHEAD(2)=X/86400. X=X-FLOAT(IHEAD(2))*86400. IHEAD(3)=X/3600. X=X-FLOAT(IHEAD(3))*3600. IHEAD(4)=X/60. ITERFRST = ITERA(ISTARTM,INPT(121)) IF (ITER .EQ. ITERFRST) THEN write(6,"(/72('-'),/'OUTPUT: iter = ',i6,' (1st iter of run,', + ' header copied from start history)')") iter DO 5 I=5,512 5 IHEAD(I) = ITERT(I) ELSE write(6,"(/72('-'),/'OUTPUT: iter = ',i6)") iter NINPT = 160 DO 10 N=1,NINPT IHEAD(4+N)=INPT(N) c c Calendar year and day were advanced in advnce -- copy to header: c if (iadvda.eq.1.and.n.eq.41) ihead(4+n) = iyear if (iadvda.eq.1.and.n.eq.42) ihead(4+n) = iiday 10 CONTINUE NPAR1 = NINPT + 4 + 1 IHEAD(NPAR1) = NAURP DO 11 N=1,NAURP HEAD(NPAR1+N)=PARAMV(N) 11 CONTINUE NTH = 30 DO 12 N=1,NTH 12 HEAD(NPAR1+NAURP+N)=THETA0(N) NROT0 = NPAR1 + NAURP + NTH NROT = 30 DO 13 N=1,NROT 13 HEAD(NROT0+N)=RRAD(N) C **** SAVE MODEL NUMBER, O+O COLLISION FACTOR AND F107 FLUX IN C **** THE HEADER. NEX1 = NROT0 + NROT + 1 HEAD(NEX1)= 4.40 HEAD(NEX1+1) = COLFAC HEAD(NEX1+2) = F107 HEAD(NEX1+3) = F107A C **** PRINT OUT PART OF HEADER. C WRITE(6,"(1X,'OUTPUT: ',A8,2X,'NAURP=',I3)")IHEAD(NPAR1-1), C 1 IHEAD(NPAR1) C WRITE (6,1010) (PMVC(I),I=1,NAURP) 1010 FORMAT (1X, 8(4X,A8) ) C WRITE (6,1011) (HEAD(I),I=NPAR1+1,NPAR1+NAURP) 1011 FORMAT (1X, 8E12.5) C WRITE (6,1010) (THET0C(I),I=1,NTH) C WRITE (6,1011) (HEAD(I),I=NPAR1+NAURP+1,NPAR1+NAURP+NTH) C WRITE (6,1010) (ROTC(I),I=1,NROT) C WRITE (6,1011) (HEAD(I),I=NROT0+1,NROT0+NROT) C WRITE (6,1010) (MCF(I),I=1,4) C WRITE (6,1011) (HEAD(I),I=NEX1,NEX1+3) ENDIF ! FOR FIRST ITER OR NOT c write(6,"('Write ',a,' history ',i3,':',i2,':',i2,' to ', + 'volume ',a)") htype(1:len_trim(htype)), + (ihead(i),i=2,4),mssvol(1:len_trim(mssvol)) if (iadvda.eq.1) + write(6,"('Calendar year,day = ',i4,',',i3)") (ihead(i),i=45,46) c c Use summary (f(1-lsumm)) to store secondary history buffer length c and field flags: c c 3/95: Write model parameters to summary for post processors: c 8/96: Write fields on history to summary c do i=1,lsumm f(i,1) = 0. enddo f(1,1) = 1. ! information is available here f(2,1) = float(zimx) ! number of longitudes f(3,1) = float(zjmx) ! number of latitudes f(4,1) = float(zkmx) ! number of vertical (half) levels f(5,1) = zst ! top level (zp) f(6,1)= zsb ! bottom level (zp) f(7,1) = nfproc ! number of fields (if not sech) f(8,1) = 1. ! is dynamo model f(9,1) = 0. ! is time-gcm (not ti(e)gcm) f(10,1) = 0. ! is coupled run read(tgcm_version,"(a)") f(11,1) ! version name f(12,1) = 0. ! is primary history if (isech.gt.0) then ! is secondary history f(12,1) = float(lbsech) ! length of secondary hist latitude buffer nfs = 0 c c secflds are the requested secondary history fields c (primary and diagnostic) c secflds_hist are the fields actually written to the secondary history c (secflds_hist will always have the requested primary fields, but will c have the requested diagnostic fields only if addfsech was actually c called for that field) c do i=1,mxfsech if (len_trim(secflds_hist(i)).gt.0) then nfs = nfs+1 read(secflds_hist(i),"(a)") f(nfs+12,1) elseif (i.le.nfsech) then ! requested field was not written c c First iter means diagnostic sec fields have not yet been calculated. c Mkfsech will give them 1.e36, but note secflds_hist(i) is left blank. c It will be defined non-blank when and if addfsech is called for that c field. c if (iter .eq. iterfrst) then write(6,"('1st iter: diagnostic secondary ', + 'history field ',a,' gets spval ',e9.2)") + secflds(i),spval nfs = nfs+1 read(secflds(i),"(a)") f(nfs+12,1) c c Diagnostic sec field secflds_hist(i) apparently not defined after c 1st iteration: write warning and do not include it in list of names: c else write(6,"('WARNING: secondary diagnostic field ',a, + ' is undefined -- not written to secondary history.')") + secflds(i)(1:len_trim(secflds(i))) write(6,"(' (Use sub addfsech to add diagnostic fields', + ' to secondary histories.)')") endif endif enddo f(7,1) = nfs else ! field names of primary history do i=1,nfproc f(i+12,1) = fproc_names(i) enddo endif if ((isech.le.0.and.ncallprim.eq.1).or. + (isech.gt.0.and.ncallsec.eq.1)) then write(6,"(' tgcm model version name: ',a)") f(11,1) write(6,"(' zimx = ',f8.2,' (number of longitudes)')") f(2,1) write(6,"(' zjmx = ',f8.2,' (number of latitudes)')") f(3,1) write(6,"(' zkmx = ',f8.2,' (number of vertical layers', + ' (half-levels))')") f(4,1) write(6,"(' zst = ',f8.2,' (top level zp)')") f(5,1) write(6,"(' zsb = ',f8.2,' (bottom level zp)')") f(6,1) write(6,"(' dyn = ',f8.2,' (if dyn > 0 is dynamo model,', + ' otherwise non-dynamo)')") f(8,1) write(6,"(' typ = ',f8.2,' (if typ > 0 is timegcm,', + ' otherwise is ti(e)gcm)')") f(9,1) write(6,"(' cpl = ',f8.2,' (if cpl > 0, is coupled run ', + 'tgcm/ccm)')") f(10,1) if (isech.gt.0) then write(6,"(' nfs= ',f8.2,' (number of fields)')") + float(nfs) write(6,"('Fields on this secondary history:')") write(6,"('(Fields marked with ''*'' are non-primary ', + '(diagnostic) history fields.)')") do i=1,nfs ip = 0 do ii=1,nfproc if (f(i+12,1).eq.fproc_names(ii)) ip=ii enddo if (ip.gt.0) then write(6,"(a,' ',$)") f(i+12,1) else char8 = ' ' write(char8,"(a)") f(i+12,1) write(6,"(a,'* ',$)") char8(1:len_trim(char8)) endif if (mod(i,8).eq.0.or.i.eq.nfs) write(6,"(' ')") enddo else write(6,"(' nflds= ',f8.2,' (number of fields)')") f(7,1) write(6,"('Fields on this history:')") do i=1,nfproc write(6,"(a,' ',$)") f(i+12,1) if (mod(i,8).eq.0.or.i.eq.nfproc) write(6,"(' ')") enddo endif elseif (isech.gt.0) then write(6,"('Fields on this secondary history:')") write(6,"('(Fields marked with ''*'' are non-primary ', + '(diagnostic) history fields.)')") do i=1,nfs ip = 0 do ii=1,nfproc if (f(i+12,1).eq.fproc_names(ii)) ip=ii enddo if (ip.gt.0) then write(6,"(a,' ',$)") f(i+12,1) else char8 = ' ' write(char8,"(a)") f(i+12,1) write(6,"(a,'* ',$)") char8(1:len_trim(char8)) endif if (mod(i,8).eq.0.or.i.eq.nfs) write(6,"(' ')") enddo endif c MODULO=3 CALL INIT ifill=ifill+1 if (isech.le.0) then ifil = ifil+1 else ifilsech = ifilsech+1 endif c c Write header: c BUFFER OUT(luhist,1) (IHEAD,IHEAD(512)) istat = unit(luhist) if (istat.ge.0) then ! error writing header num = 520 goto 5000 endif c c Summary includes lbsech (f(1)) and secflds(mxfsech) if doing c secondary histories. This information will be used by post-model c processors (f(1)=0. if not secondary hist): c BUFFER OUT(luhist,1) (F,F(lsumm)) istat = unit(luhist) if (istat.ge.0) then ! error writing summary num = 550 goto 5000 endif c write(6,"('output wrote summary: f(1,1)=',f8.1,' f(2-31,1)=', c + /30f5.1)") f(1,1),(f(i,1),i=2,31) c c Read j=1 from sds unit: c CALL FLIP CALL UNLCRD (IUNIN,NJ,LBDSKI,NSIN) CALL UNLCCK(IUNIN,NSIN,LEN) if (len.ne.lbdski.or.nsin.ne.0) then ! error reading j=1 num = 570 goto 4000 endif c c Main latitude loop: c n1 = 1 n2 = 2 DO 640 J=1,JMAX c write(6,"('output: j=',i2,' isech=',i2,' luhist=',i2)") c + j,isech,luhist CALL FLIP ! rotate indices for f array call flips(n1,n2) ! rotate indices for fsech if (j.ne.1) then if (isech.le.0) then CALL UNLCWT(luhist,NJM2,lbtape,NSOT) else ! secondary history buffer out(luhist,1)(fsech(1,1,1,n1),fsech(lbsech,1,1,n1)) c write(luhist,iostat=ios) fsech(1:lbsech,1,1,n1) c if (ios /= 0) then c write(6,"('>>> output: error writing fsech to ', c + 'luhist=',i2,' lbsech=',i6,' j=',i2,' ios=',i5)") c + luhist,lbsech,j,ios c stop 'sec hist' c endif endif endif if (j.ne.jmax) CALL UNLCRD (IUNIN,NJ,LBDSKI,NSIN) NXK = NJM1 C **** C **** INSERT DYNAMO AND HEELIS POTENTIALS IN HISTORY C **** NPHIK = NJM1+NPHI-1 DO 591 K = 1,KMAXP1 NPHIK = NPHIK+1 DO 591 I = 1,IMAX F(I+2,NPHIK) = DYNPOT(I,J,K) 591 CONTINUE NPHIHK = NJM1+NPHIH DO 593 I = 1,IMAX F(I+2,NPHIHK) = PHIH(I,J) 593 CONTINUE C **** C **** PERIODIC POINTS C **** DO 592 I = 1,2 NPHIK = NJM1+NPHI-1 DO 592 K = 1,KMAXP1 F(I,NPHIK+K) = F(I+IMAX,NPHIK+K) F(I+IMAX+2,NPHIK+K) = F(I+2,NPHIK+K) 592 CONTINUE NPHIHK = NJM1+NPHIH DO 594 I = 1,2 F(I,NPHIHK) = F(I+IMAX,NPHIHK) F(I+IMAX+2,NPHIHK) = F(I+2,NPHIHK) 594 CONTINUE c c Define fields for secondary history and change to "external format": c (mksech returns # fields defined in nf) c (mkfsech will print debug msgs if its last arg is current j) c (mkfsech defines primary fields from f, and diagnostic fields c from direct access file lusech1) c if (isech.gt.0) then ifirst = 0 if (iter .eq. iterfrst) ifirst = 1 call mkfsech(fsech,n2,njm1,nf,j,ifirst,0) fsech(1,1,1,n2) = -j ix = 1 do n=1,kmaxp1*nf do i=3,imaxp4 ix = ix+1 fsech(ix,1,1,n2) = fsech(i,n,1,n2) enddo enddo else ! regular history c c Change f array from internal to external format (regular history): c F(1,NXK) = -J IX = 1 DO N=1,NCOLS DO I=3,IMAXP4 IX = IX+1 F(IX,NXK) = F(I,NXK+N-1) enddo enddo endif c c Check for completion of buffering (luhist is secondary or regular): c if (j.ne.1) then CALL UNLCCK(luhist,NSOT,LEN) if (len.ne.lbtape.or.nsot.ne.0) then ! error writing lat slice NUM=630 GO TO 5000 endif endif if (j.ne.jmax) then CALL UNLCCK(IUNIN,NSIN,LEN) if (len.ne.lbdski.or.nsin.ne.0) then ! error writing lat slice NUM=640 GO TO 4000 endif endif 640 continue ! latitude loop c c Write last latitude, j=jmax: c CALL FLIP call flips(n1,n2) if (isech.le.0) then CALL UNLCWT(luhist,NJM2,lbtape,NSOT) else ! secondary history buffer out(luhist,1)(fsech(1,1,1,n1),fsech(lbsech,1,1,n1)) c write(luhist,iostat=ios) fsech(1:lbsech,1,1,n1) c if (ios /= 0) then c write(6,"('>>> output: error writing fsech to ', c + 'luhist=',i2,' lbsech=',i6,' j=(last) ios=',i5)") c + luhist,lbsech,ios c stop 'sec hist' c endif endif CALL UNLCCK(luhist,NSOT,LEN) c istat = ishell('ls -l SECHIST') c write(6,"('output after buffer out and unlcck: isech=',i2, c + ' luhist=',i2,' lbsech=',i6,' len=',i6,' istat=',i2)") c + isech,luhist,lbsech,len,istat if (len.ne.lbtape.or.nsot.ne.0) then NUM=650 GO TO 5000 endif CALL TRNSFR(labhist(1,itape),labhist(1,itape),3,2) c c Report to stdout and make new volinfo for mss comment field: c iyd = (ihead(45)-1900)*1000+ihead(46) read(hvolinfo,"(i5)",err=100) iydrd goto 101 100 write(6,"('>>> WARNING output: error reading iyd from ',a, + 'hvolinfo -- hvolinfo=',a)") htype,hvolinfo iydrd = -1 101 continue if (iydrd.ge.0) then ! not first hist this vol -- update end only call mkvolinfo(0,0,0,0,iyd,ihead(2),ihead(3),ihead(4), + idelmin,1,tgcm_version,isech,hvolinfo) else ! first hist on this vol iyd = (inpt(41)-1900)*1000+inpt(42) call mkvolinfo(iyd,ihead(2),ihead(3),ihead(4), + iyd,ihead(2),ihead(3),ihead(4), + 0,0,tgcm_version,isech,hvolinfo) endif write(6,"(/'Histories on volume ',a,':',/a)") + mssvol(1:len_trim(mssvol)),hvolinfo(1:len_trim(hvolinfo)) c c Reset history write flags and volinfo: c REWIND IUNIN ihisto=mhist if (isech.le.0) then ihis = mhis volinfo = hvolinfo else ihissech = mhissech volinfo_sech = hvolinfo endif c CALL TRNSFR(labhist(1,itape),labhist(1,itape),3,1) IF (ifill.LT.mfill) THEN ! full history volume write(6,"(72('-')/)") RETURN ELSE IF (ITER.GE.NSTP) THEN ! end of run write(6,"('output returning: iter=',i5,' nstp=',i3)") + iter,nstp write(6,"(72('-')/)") RETURN C **** CHECK IF ENOUGH VOLUMES ELSE IF (itape.GE.mtape) THEN ! not enough history volumes WRITE(6,704) 704 FORMAT(* OUTPUT -- NOT ENOUGH HISTORY VOLUMES*) NERR=1 write(6,"(72('-')/)") RETURN c c Dispose volume to mss and open new disk file: c ELSE ! dispose volume to mss CLOSE(luhist,iostat=ios) if (isech.le.0) then ! full restart history CALL DISPTP(labhist(1,itape),7HHISTCPY,IDISP,luhist,tmpdir, + volinfo) else ! secondary history CALL DISPTP(labhist(1,itape),7HSECHIST,IDISP,luhist,tmpdir, + volinfo_sech) endif call mkvolinfo(-1,-1,-1,-1, -1,-1,-1,-1, -1,0,tgcm_version, + isech,hvolinfo) if (isech.le.0) then ! primary history ISTAT = unlink('HISTCPY') IF(ISTAT.NE.0) + WRITE(6,"('>>> OUTPUT: problem deleting HISTCPY, istat=', + i2)")ISTAT OPEN(UNIT=luhist,FILE='HISTCPY',STATUS='NEW',IOSTAT=IOS, + FORM='UNFORMATTED') IF(IOS.NE.0) + WRITE(6,"('>>> OUTPUT: problem opening HISTCPY, ios=',i2)") + IOS ifil=0 itap=itap+1 if (isav.eq.0) isav=msav volinfo = hvolinfo else ! secondary history ISTAT = unlink('SECHIST') IF(ISTAT.NE.0) + WRITE(6,"('>>> OUTPUT: problem deleting SECHIST, istat=', + i6)")ISTAT OPEN(UNIT=luhist,FILE='SECHIST',STATUS='NEW',IOSTAT=IOS, + FORM='UNFORMATTED') IF(IOS.NE.0) + WRITE(6,"('>>> OUTPUT: problem opening SECHIST, ios=',i6)") + IOS ifilsech=0 itapsech=itapsech+1 if (isavsech.eq.0) isavsech=msavsech volinfo_sech = hvolinfo endif ifill=0 itape=itape+1 if (isave.eq.0) isave=msave write(6,"(72('-')/)") RETURN ENDIF 4000 WRITE(6,4010) NUM,LEN,NSIN,J 4010 FORMAT(*1DISK PROBLEM IN OUTPUT AT NUM=*I5,2X,*LEN=*I5,2X,*NSIN=* AI1,2X,*J=*I2) CALL EXIT C **** BAD HISTORY TAPE 5000 WRITE(6,5010) NUM,LEN,NSOT,J 5010 FORMAT(*1HIST PROBLEM IN OUTPUT AT NUM=*I5,2X,*LEN=*I5,2X,*NSOT=* AI1,2X,*J=*I2) CALL EXIT END