C+
C NAME:
C	WR2DARR
C PURPOSE:
C	Write 2D array to file
C CALLING SEQUENCE:
	subroutine WR2DARR(ID,nX,nY,Z,cFile,cFrmt,bMirror,iStr,cStr)
C INPUTS:
C	ID		integer		1: write to new file
C					0: append to existing file
C					(adding 2 suppresses messages to screen)
C	nX		integer		size of first dimension
C	nY		integer		size of second dimension
C	Z(nX,nY)	real		array to be written to file
C	cFile		character*(*)	name of output file
C	cFmt		character	format to be used for output
C	bMirror		logical		(see PROCEDURE)
C	iStr		integer		# comment strings
C	cStr(iStr)*(*)	character*(*)	comments strings (see PROCEDURE)
C OUTPUTS:
C	Z(nX,nY)	real		the input array will be modified if
C					values are present that don't fit the
C					input format: these will be set to BadR4()
C
C	Output file cFile is created
C INCLUDE:
	include		'filparts.h'
	include		'dirspec.h'
	include		'openfile.h'
C CALLS:
C	uppercase, LocFirst, LocFirstLen, Str2Flt, cFlt2Str, Say, bOpenFile, BadR4, BadI4
C	ArrR4GetMinMax, iArrR4ValuePresent, ArrR4Mask, cTime2System, itrim, iFreeLun
C RESTRICTIONS:
C >	!!!! Numbers in the input array that do not modify the format
C 	!!!!		 WILL BE SET TO BadR4()
C >	iStr must be >= 1
C PROCEDURE:
C >	The array is checked for values BadI4() (I format) or BadR4() (E,F format).
C	For I format 'bad' elements are replaced by the biggest negative integer
C	that fits the format, with the restriction that the number is not smaller
C	than BadI4() (=the biggest negative 32-bit integer).
C	For F format 'bad' elements are replaced by the bigges negative real*4 number
C	that fits the format, with the restriction that there are no more than 7 leading
C	digits of 9 (it the format contains more digits these are set to zero).
C >	If bMirror = .FALSE. then Z will be output row after row (I=1,NX).
C	If bMirror = .TRUE.  then Z will be output column after column (I=1,NY).
C >	If the format specifier is an integer format, the floating point array
C	Z will be output using the NINT function.
C >	If the format specifier cFmt does not contain a repeat counter than
C	nX is used (or nY if bMirror=.TRUE.). If a repeat counter
C	is used, it should be <= than nX (or nY).
C >	If a repeat counter N is used each row (or column) will be split over
C	multiple records with N numbers per record. The last record output for
C	a row (or column) will contain less numbers than N if N is not a
C	factor of nX (or nY).
C >	The iStr comment strings are written to the beginning of the file
C	with a semi-colon (;) prepended. Empty strings (itrim()=0) are skipped.
C >	A new file (ID > 0) will be started with one or two comment strings (preceded
C	by a semi-colon). The first contains the file name retured by bOpenFile (this
C	should be a fully-qualified file name) and the time and date when the file
C	was created. The second line contains the value used to replace BadR4() values
C	in the output file. This line looks like e.g.
C		; Bad value flag: -9999.99
C >	The output file is created as a sequential acces, formatted file.
C MODIFICATION HISTORY:
C	DEC-1995, Paul Hick (UCSD/CASS)
C	???-2000, Paul Hick (UCSD/CASS)
C		added option to suppress messages to screen by adding 2 to ID.
C	SEP-2001, Paul Hick (UCSD/CASS)
C		added output of more extensive message to screen when values in the input
C		array do not fit the specified format. This message is never suppressed.
C		Also modified the declaration of string cStr from cStr(iStr)*(*) to
C		cStr(*)*(*), removing the restriction iStr >=1.
C	MAY-2002, Paul Hick (UCSD/CASS; pphick@ucsd.edu)
C		Fixed minor bug: the test for values that don't fit the output format
C		cFmt, sometimes generated a unnecessary warning message.
C-
	    integer	ID
	    integer	nX
	    integer	nY
	    real	Z(nX,nY)
	    character	cFile*(*)
	    character	cFrmt*(*)
	    logical	bMirror
	    integer	iStr
	    character	cStr(*)*(*)

	logical		bInteger
	logical		bReal
	logical		bMessage

	character	Frmt*40		/' '/
	character	FrmtSub*8
	character	FrmtBad*20
	character	cFileName*(FIL__LENGTH)
	character	cTime2System*80
	character	cSay*7		/'Wr2DArr'/
	character	cBad*20
	character	cFlt2Str*14
	integer		iB		/4/
	integer		BadI4
	logical		bOpenFile

	bMessage = ID .le. 1

	Frmt(iB: ) = cFrmt(LocFirst('(',cFrmt):)
	call uppercase(Frmt)

	bInteger = LocFirst('I',Frmt) .ne. 0
	bReal    = LocFirst('F',Frmt) .ne. 0
	I = min(LocFirstLen('F',Frmt),LocFirstLen('I',Frmt),LocFirstLen('E',Frmt))

	if (I .eq. iB+1) then		! (I
	    FrmtBad = Frmt(iB:iB)//'A,'//Frmt(iB+1:)

	    Frmt(:1) = Frmt(iB:iB)	! Move ( to beginning of Frmt
	    write (FrmtSub,'(A,I2.2,A,I2.2,A)') '(I',iB-1,'.',iB-1,')'
	    if (bMirror) then		! Insert repeat counter
		write (Frmt(2:iB),FrmtSub) nY
		iY = nY
	    else
		write (Frmt(2:iB),FrmtSub) nX
		iX = nX
	    end if
	else
	    FrmtBad = Frmt(iB:iB)//'A,'//Frmt(I:)

	    IV = 1
	    call Str2Flt(Frmt(iB+1:I-1),IV,RV)
	    if (bMirror) then
		iY = RV
	    else
		iX = RV
	    end if
	    Frmt = Frmt(iB:)
	    I = I-iB+1
	end if

	I    = I+1				! After I,E or F
	JDot = min(LocFirstLen('.',Frmt),LocFirstLen(')',Frmt))

	IV = 1
	call Str2Flt(Frmt(I:JDot-1),IV,RV)	! 5 in F5.1 or I5
	nL = nint(RV)

	!-------
	! For I and F formats determine the biggest negative number that fits the format
	! as proxy for 'bad' values. For E format use BadR4()

	BadOut = BadR4()
	if (bInteger .or. bReal) then

	    if (bInteger) then
		cBad(1:) = '-'			! Start with minus sign
		do I=2,nL			! All 99999
		    cBad(I:I) = '9'
		end do

		BadOut = BadI4()
		if (nL .lt. 11) then		! For integer make sure not to go
		    IV = 1			! ... below biggest negative 32-bit integer
		    call Str2Flt(cBad,IV,BadOut)
		end if

	    else if (bReal) then
		IV = 1
		call Str2Flt(Frmt(JDot+1:),IV,RV)! 1 in F5.1
		JDot = nL-nint(RV)		! Position of dot

		cBad(1:) = '-'			! Start with minus sign
		J = 0
		do I=2,nL
		    if (I .eq. JDot) then	! Insert dot
			cBad(I:I) = '.'
		    else if (J .lt. 7) then	! No more than 7 nines.
			cBad(I:I) = '9'
			J = J+1
		    else			! Switch from 9 to 0
			cBad(I:I) = '0'		! (single precision can't handle more 9's)
		    end if
		end do

		IV = 1				! below biggest negative 32-bit integer
		call Str2Flt(cBad,IV,BadOut)
	    end if

	end if

	Bad = BadR4()
	if (bInteger) Bad = BadI4()

	!-------
	! Bad values in the array Z won't fit the output format, so we replace
	! them with BadOut values (the original bad values are restored before
	! returning).

	if (BadOut .ne. Bad) then

	    call ArrR4GetMinMax(-nX*nY,Z,Zmin,Zmax)

	    !-------
	    ! Check whether any of the good values in Z don't fit the output format.
	    ! If the whole array Z is bad then Zmin = Zmax = Bad, and there are no
	    ! good values to check.

	    if (Zmin .ne. Bad .and. (Zmin .lt. BadOut .or. Zmax .gt. -BadOut)) then ! Assumes BadOut << 0

		ZTooLarge =  Bad		! Initialize to big negative number
		ZTooSmall = -Bad		! Initialize to big positive number

		!-------
		! Set valid function values that don't fit the output format to BadOut.

		do J=1,nY
		    do I=1,nX
		    	if (Z(I,J) .ne. Bad) then
			    if (Z(I,J) .lt.  BadOut) then
				ZTooSmall = min(ZTooSmall,Z(I,J))
				Z(I,J) = Bad
			    end if

			    if (Z(I,J) .gt. -BadOut) then
				ZTooLarge = max(ZTooLarge,Z(I,J))
				Z(I,J) = Bad
			    end if
			end if
		    end do
		end do

		!-------
		! Display warning: input values that don't fit the output format
		! have been set to Bad, i.e. the input array has been modified.

		if (ZTooSmall .ne. -Bad) call Say(cSay,'W',cFile,
     &			'Input modified ! Small values not fitting format flagged as bad'//
     &			'#Smallest value is '//cFlt2Str(ZTooSmall,4))

		if (ZTooLarge .ne.  Bad) call Say(cSay,'W',cFile,
     &			'Input modified ! Large values not fitting format flagged as bad'//
     &			'#Largest values is '//cFlt2Str(ZTooLarge,4))

	    end if

	    !-------
	    ! Display a warning if BadOut already is present in Z. If it is then information is
	    ! lost in the output file: the BadOut values already present cannot be
	    ! distinguished from BadOut values used to mark bad function values in the
	    ! input array.

	    if (iArrR4ValuePresent(nX*nY,Z,BadOut) .ne. 0)
     &		call Say(cSay,'W',cFile,'Bad value flag '//cBad(:itrim(cBad))//' already present in file')

	    !-------
	    ! Replace Bad values by BadOut (will be restored to Bad before returning).

	    call ArrR4Mask(nX*nY,Z,Bad,BadOut,0.0,0.0,1.0,Z)

	end if

	iAct = OPN__TRYINPUT+OPN__ONEPASS+OPN__STOP+OPN__FORMATTED	! Formatted file
	iRecl = nX*nL/4							! Record length in long words
	if (iRecl*4 .ne. nX*nL) iRecl = iRecl+1
	cFileName = cFile

	if (mod(ID,2) .gt. 0) then
	    iAct  = iAct+OPN__SEQUENTIAL				! Sequential access
	    if (cOpSys .eq. OS__VMS) iAct = iAct+OPN__NEW		! New file (with higher version # on VMS)
	    if (cOpSys .ne. OS__VMS) iAct = iAct+OPN__UNKNOWN		! Other OS: overwrite existing file
	    if (ID .gt. 1) iAct = iAct+OPN__NOMESSAGE

	    if (bOpenFile(iAct,iU,cFileName,iRecl)) then
		if (bMessage) call Say(cSay,'I','writing','to '//cFileName)
		write (iU,'(3A,A19)' ) '; ',cFileName(:itrim(cFileName)),' created on ',cTime2System(' ')
		write (iU,FrmtBad) '; Bad value flag: ',BadOut
	    end if

	else
	    iAct  = iAct+OPN__APPEND+OPN__NOPARSE			! Append to sequential access file
	    if (ID .gt. 1) iAct = iAct+OPN__NOMESSAGE

	    if (bOpenFile(iAct,iU,cFileName,iRecl)) then
		if (bMessage) call Say(cSay,'I','appending','to '//cFileName)
	    end if

	end if

	do I=1,iStr
	    J = itrim(cStr(I))
	    if (bMessage .and. I .eq. 1) call Say(cSay,'I','Info',cStr(1))
	    if (J .ne. 0) write (iU,'(2A)') '; ',cStr(I)(:J)
	end do

	if (bMirror) then
	    if (bInteger) then
		if (iY .eq. nY) then
		    write (iU,Frmt) ((nint(Z(I,J)), J=1,nY), I=1,nX)
		else
		    do I=1,nX
			do J=0,nY/iY-1
			    write (iU,Frmt) (nint(Z(I,J*iY+K)), K=1,iY)
			end do
			kY = nY/iY*iY
			if (kY .lt. nY) write (iU,Frmt) (nint(Z(I,J)), J=kY+1,nY)
		    end do
		end if
	    else
		if (iY .eq. nY) then
		    write (iU,Frmt) ((Z(I,J), J=1,nY), I=1,nX)
		else
		    do I=1,nX
			do J=0,nY/iY-1
			    write (iU,Frmt) (Z(I,J*iY+K), K=1,iY)
			end do
			kY = nY/iY*iY
			if (kY .lt. nY) write (iU,Frmt) (Z(I,J), J=kY+1,nY)
		    end do
		end if
	    end if
	else
	    if (bInteger) then
		if (iX .eq. nX) then
		    write (iU,Frmt) ((nint(Z(I,J)), I=1,nX), J=1,nY)
		else
		    do J=1,nY
			do I=0,nX/iX-1
			   write (iU,Frmt) (nint(Z(I*iX+K,J)), K=1,iX)
			end do
			kX = nX/iX*iX
			if (kX .lt. nX) write (iU,Frmt) (nint(Z(I,J)), I=kX+1,nX)
		    end do
		end if
	    else
		if (iX .eq. nX) then
		    write (iU,Frmt) ((Z(I,J), I=1,nX), J=1,nY)
		else
		    do J=1,nY
			do I=0,nX/iX-1
			   write (iU,Frmt) (Z(I*iX+K,J), K=1,iX)
			end do
			kX = nX/iX*iX
			if (kX .lt. nX) write (iU,Frmt) (Z(I,J), I=kX+1,nX)
		    end do
		end if
	    end if
	end if

	iU = iFreeLun(iU)		! Also closes file

	!-------
	! Restore BadOut values to Bad. This will restore the input array Z
	! except for valid function values that did not fit the output format.
	! These will now also be set to Bad.

	if (Bad .ne. BadOut) call ArrR4Mask(nX*nY,Z,BadOut,Bad,0.,0.,1.,Z)

	return
	end