*IF DEF,SETUP,OR,DEF,COMB WRITFTX1.2
C ******************************COPYRIGHT****************************** GTS2F400.12115
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.12116
C GTS2F400.12117
C Use, duplication or disclosure of this code is subject to the GTS2F400.12118
C restrictions as set forth in the contract. GTS2F400.12119
C GTS2F400.12120
C Meteorological Office GTS2F400.12121
C London Road GTS2F400.12122
C BRACKNELL GTS2F400.12123
C Berkshire UK GTS2F400.12124
C RG12 2SZ GTS2F400.12125
C GTS2F400.12126
C If no contract has been raised with this copy of the code, the use, GTS2F400.12127
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.12128
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.12129
C Modelling at the above address. GTS2F400.12130
C ******************************COPYRIGHT****************************** GTS2F400.12131
C GTS2F400.12132
CLL Routine: WRITFTXX ------------------------------------------------- WRITFTX1.3
CLL WRITFTX1.4
CLL Purpose: To create file of user fortran unit assignment details WRITFTX1.5
CLL taken from common history block information. WRITFTX1.6
CLL WRITFTX1.7
CLL Tested under compiler: cft77 WRITFTX1.8
CLL Tested under OS version: UNICOS 5.0 WRITFTX1.9
CLL WRITFTX1.10
CLL Author: A.B.SANGSTER WRITFTX1.11
CLL WRITFTX1.12
CLL Model Modification history from model version 3.0: WRITFTX1.13
CLL version date WRITFTX1.14
CLL 3.1 2/02/93 : Added comdeck CHSUNITS to define NUNITS for RS030293.70
CLL extra I/O RS030293.71
CLL AD050293.136
CLL 3.1 05/02/93 Portable Fortran unit no assigns AD050293.137
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.138
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.246
CLL portability. Author Tracey Smith. TS150793.247
CLL WRITFTX1.15
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) WRITFTX1.16
CLL WRITFTX1.17
CLL Logical components covered: C0 WRITFTX1.18
CLL WRITFTX1.19
CLL Project task: C0 WRITFTX1.20
CLL WRITFTX1.21
CLL External documentation: On-line UM document C0 - The top-level WRITFTX1.22
CLL control system WRITFTX1.23
C*L Interface and arguments: WRITFTX1.24
C WRITFTX1.25
SUBROUTINE WRITFTXX 2,1WRITFTX1.26
* ( UNITFTXX,ICODE,CMESSAGE ) WRITFTX1.27
C WRITFTX1.28
IMPLICIT NONE WRITFTX1.29
C WRITFTX1.30
INTEGER UNITFTXX ! In - FTXX file unit WRITFTX1.31
INTEGER ICODE ! Out - Return code from routine WRITFTX1.32
CHARACTER*(80) CMESSAGE ! Out - Return message if failure occured TS150793.248
CHARACTER *80 FILENAME AD050293.139
C* WRITFTX1.34
C WRITFTX1.35
CL Common blocks WRITFTX1.36
C WRITFTX1.37
*CALL CHSUNITS 
RS030293.72
*CALL CLFHIST WRITFTX1.38
C WRITFTX1.39
C*L EXTERNAL subroutines called WRITFTX1.40
EXTERNAL GET_FILE AD050293.140
C* WRITFTX1.42
CL local variables RS030293.73
C RS030293.74
INTEGER I ! index for loop RS030293.75
C WRITFTX1.43
CL WRITFTX1.44
CL 1. Open, rewind and write a record WRITFTX1.45
CL WRITFTX1.46
CALL GET_FILE(UNITFTXX,FILENAME,80,ICODE) GTD0F400.169
OPEN(UNITFTXX,FILE=FILENAME,IOSTAT=ICODE) ! OPEN THE OUTPUT FILE AD050293.142
C WRITFTX1.48
C Check for error WRITFTX1.49
C WRITFTX1.50
IF(ICODE .GT.0)THEN WRITFTX1.51
CMESSAGE='WRITFTXX: Failed in OPEN of output unit' WRITFTX1.52
GOTO 999 WRITFTX1.53
ELSEIF(ICODE .LT. 0)THEN WRITFTX1.54
WRITE(6,*)'WRITFTXX: Warning message on OPEN of output unit' GIE0F403.685
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.686
ENDIF WRITFTX1.57
C WRITFTX1.58
REWIND(UNITFTXX) WRITFTX1.59
DO I=1,NUNITS RS030293.76
WRITE(UNITFTXX,100,IOSTAT=ICODE)MODEL_FT_UNIT(I) RS030293.77
ENDDO RS030293.78
C WRITFTX1.61
C Check for error WRITFTX1.62
C WRITFTX1.63
IF(ICODE .GT.0)THEN WRITFTX1.64
CMESSAGE='WRITFTXX: Failed in WRITE to output unit' WRITFTX1.65
GOTO 999 WRITFTX1.66
ELSEIF(ICODE .LT. 0)THEN WRITFTX1.67
WRITE(6,*)'WRITFTXX: Warning message on WRITE to output unit' GIE0F403.687
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.688
ENDIF WRITFTX1.70
C WRITFTX1.71
C WRITFTX1.72
100 FORMAT(A80) RS030293.79
999 CONTINUE WRITFTX1.74
CL WRITFTX1.75
CL 2. Close and return WRITFTX1.76
CL WRITFTX1.77
CLOSE(UNITFTXX) WRITFTX1.78
RETURN WRITFTX1.79
END WRITFTX1.80
*ENDIF WRITFTX1.81