*IF DEF,C92_1A FRACTM1A.2
C ******************************COPYRIGHT****************************** GTS2F400.3133
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.3134
C GTS2F400.3135
C Use, duplication or disclosure of this code is subject to the GTS2F400.3136
C restrictions as set forth in the contract. GTS2F400.3137
C GTS2F400.3138
C Meteorological Office GTS2F400.3139
C London Road GTS2F400.3140
C BRACKNELL GTS2F400.3141
C Berkshire UK GTS2F400.3142
C RG12 2SZ GTS2F400.3143
C GTS2F400.3144
C If no contract has been raised with this copy of the code, the use, GTS2F400.3145
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.3146
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.3147
C Modelling at the above address. GTS2F400.3148
C ******************************COPYRIGHT****************************** GTS2F400.3149
C GTS2F400.3150
CLL SUBROUTINE FRAC_TIM------------------------------------------------ FRACTM1A.3
CLL FRACTM1A.4
CLL Purpose: Calculates fractional time at which DATA field changes FRACTM1A.5
CLL from zero to non-zero or vice versa. The algorithm FRACTM1A.6
CLL assumes that the changes progress in the latitudindal FRACTM1A.7
CLL direction from time T1 - T2. Used for snow depth and FRACTM1A.8
CLL ice-fraction. FRACTM1A.9
CLL FRACTM1A.10
CLL Written by A. Dickinson 30/03/90 FRACTM1A.11
CLL FRACTM1A.12
CLL Model Modification history from model version 3.0: FRACTM1A.13
CLL version date FRACTM1A.14
CLL AD150193.1
CLL 3.1 15/01/93 Correct error in logic AD150193.2
CLL Author: A. Dickinson Reviewer: C. Jones AD150193.3
CLL AD170393.1
CLL 3.2 15/03/93 Interpret RMDI a legitimate end of AD170393.2
CLL transition sequence. AD170393.3
CLL Author: A. Dickinson Reviewer: C. Jones AD170393.4
CLL FRACTM1A.15
CLL Programming standard: FRACTM1A.16
CLL Unified Model Documentation Paper No 3 FRACTM1A.17
CLL Version No 1 15/1/90 FRACTM1A.18
CLL FRACTM1A.19
CLL System component:S192 FRACTM1A.20
CLL FRACTM1A.21
CLL System task: S1 FRACTM1A.22
CLL FRACTM1A.23
CLL FRACTM1A.24
CLL Documentation: FRACTM1A.25
CLL The interpolation formulae are described in FRACTM1A.26
CLL unified model on-line documentation paper S1. FRACTM1A.27
CLL FRACTM1A.28
CLL ------------------------------------------------------------------- FRACTM1A.29
C*L Arguments:--------------------------------------------------------- FRACTM1A.30
FRACTM1A.31
SUBROUTINE FRAC_TIM(DATA_T1,DATA_T2,FRAC_TIME,P_ROWS,ROW_LENGTH) FRACTM1A.32
FRACTM1A.33
IMPLICIT NONE FRACTM1A.34
FRACTM1A.35
INTEGER FRACTM1A.36
* POINTS !IN No of points to be processed FRACTM1A.37
*,ROW_LENGTH !IN Length of row FRACTM1A.38
*,P_ROWS !IN Number of rows FRACTM1A.39
FRACTM1A.40
REAL FRACTM1A.41
* DATA_T1(ROW_LENGTH,P_ROWS) !IN Data at time T1 FRACTM1A.42
*,DATA_T2(ROW_LENGTH,P_ROWS) !IN Data at time T2 where T2>T1 FRACTM1A.43
*,FRAC_TIME(ROW_LENGTH,P_ROWS) !OUT Fractional time at which DATA FRACTM1A.44
* !changes between zero and non-zero in this time range FRACTM1A.45
FRACTM1A.46
FRACTM1A.47
C Local arrays:--------------------------------------------------------- FRACTM1A.48
INTEGER TYPE(ROW_LENGTH,P_ROWS) !Latitudinal transition indicator FRACTM1A.49
C ---------------------------------------------------------------------- FRACTM1A.50
C*L External subroutines called:---------------------------------------- FRACTM1A.51
C None FRACTM1A.52
C*---------------------------------------------------------------------- FRACTM1A.53
C Local variables:------------------------------------------------------ FRACTM1A.54
REAL FRACTM1A.55
* ALPHA !Fractional time FRACTM1A.56
*,A !Denominator in fractional time calculation FRACTM1A.57
FRACTM1A.58
INTEGER FRACTM1A.59
* I,J,JJ,JJJ,J1,J2 !Indices FRACTM1A.60
*,ITREND !N-S trend FRACTM1A.61
*,JHEM !Row of equator AD170393.5
*,J1J2 !Average value of J1 & J2 AD170393.6
C ---------------------------------------------------------------------- FRACTM1A.62
*CALL C_MDI 
FRACTM1A.63
FRACTM1A.64
C Calculate equator row AD170393.7
JHEM=P_ROWS/2 AD170393.8
AD170393.9
CL 1. Set transition indicators 1= zero -> non zero FRACTM1A.65
CL -1= non zero -> zero FRACTM1A.66
CL 0= no transition FRACTM1A.67
FRACTM1A.68
DO 100 J=1,P_ROWS FRACTM1A.69
DO 110 I=1,ROW_LENGTH FRACTM1A.70
FRACTM1A.71
IF(DATA_T1(I,J).EQ.0..AND.DATA_T2(I,J).GT.0.)THEN FRACTM1A.72
TYPE(I,J)=1 FRACTM1A.73
ELSEIF(DATA_T2(I,J).EQ.0..AND.DATA_T1(I,J).GT.0.)THEN FRACTM1A.74
TYPE(I,J)=-1 FRACTM1A.75
ELSE FRACTM1A.76
TYPE(I,J)=0 FRACTM1A.77
ENDIF FRACTM1A.78
FRACTM1A.79
C Initialise fractional time to missing data indicator or FRACTM1A.80
C 0.5 if transition FRACTM1A.81
FRAC_TIME(I,J)=RMDI FRACTM1A.82
IF(TYPE(I,J).NE.0)FRAC_TIME(I,J)=.5 FRACTM1A.83
FRACTM1A.84
110 CONTINUE FRACTM1A.85
100 CONTINUE FRACTM1A.86
FRACTM1A.87
FRACTM1A.88
Cl 2. Search by longitude for groups where transition occurs FRACTM1A.89
FRACTM1A.90
DO 200 I=1,ROW_LENGTH FRACTM1A.91
DO 210 J=1,P_ROWS-1 FRACTM1A.92
IF(TYPE(I,J).EQ.0.AND.TYPE(I,J+1).NE.0)THEN FRACTM1A.93
J1=J+1 FRACTM1A.94
J2=J+1 FRACTM1A.95
DO 220 JJ=J1+1,P_ROWS-1 FRACTM1A.96
IF(TYPE(I,JJ).EQ.TYPE(I,J1))THEN FRACTM1A.97
J2=J2+1 FRACTM1A.98
ELSEIF(TYPE(I,JJ).EQ.0)THEN FRACTM1A.99
FRACTM1A.100
A=1./FLOAT(J2-J1+2) FRACTM1A.101
FRACTM1A.102
C Compute transition indicators AD170393.10
J1J2=(J1+J2)/2 AD170393.11
IF((DATA_T1(I,J1-1).EQ.0.AND.DATA_T1(I,J2+1).EQ.0) AD170393.12
* .OR.(DATA_T1(I,J1-1).GT.0.AND.DATA_T1(I,J2+1).GT.0))THEN AD170393.13
C No transition AD170393.14
ITREND=0 AD170393.15
ELSEIF(TYPE(I,J1).EQ.1)THEN AD170393.16
C Transition is zero to non-zero AD170393.17
IF(J1J2.LT.JHEM)THEN AD170393.18
ITREND=-1 AD170393.19
ELSE AD170393.20
ITREND=1 AD170393.21
ENDIF AD170393.22
ELSEIF(TYPE(I,J1).EQ.-1)THEN AD170393.23
C Transition is non-zero to zero AD170393.24
IF(J1J2.LT.JHEM)THEN AD170393.25
ITREND=1 AD170393.26
ELSE AD170393.27
ITREND=-1 AD170393.28
ENDIF AD170393.29
ENDIF AD170393.30
FRACTM1A.109
C ITREND indicates how FRAC_TIME varies with latitude AD170393.31
IF(ITREND.EQ.1)THEN AD170393.32
DO 230 JJJ=J1,J2 FRACTM1A.112
FRAC_TIME(I,JJJ)=A*(J2-JJJ+1) FRACTM1A.113
230 CONTINUE FRACTM1A.114
ELSE IF(ITREND.EQ.-1) THEN AD170393.33
DO 240 JJJ=J1,J2 FRACTM1A.116
FRAC_TIME(I,JJJ)=A*(JJJ-J1+1) FRACTM1A.117
240 CONTINUE FRACTM1A.118
ENDIF FRACTM1A.119
FRACTM1A.120
GOTO 210 FRACTM1A.122
ENDIF FRACTM1A.123
220 CONTINUE FRACTM1A.124
ENDIF FRACTM1A.125
FRACTM1A.126
210 CONTINUE FRACTM1A.127
200 CONTINUE FRACTM1A.128
FRACTM1A.129
RETURN FRACTM1A.130
END FRACTM1A.131
*ENDIF FRACTM1A.132