SUBROUTINE READGRDETA C C THIS SUBROUTINE READS IN THE AIR FORCE SNOWDEPTH ON THE 32-KM ETA C GRID AND DISTRIBUTES TO ALL THE NODES TO COMPARE WITH THE EDAS C SNOW TO BE READ IN VIA READ_RESTRT2. C C IT WILL ALSO READ IN THE SEA-ICE, THE SSTs, THE ALBEDO, AND C THE GREENNESS FRACTION. C C PERRY SHAFRAN - 27 NOVEMBER 2002 C INCLUDE "parmeta" INCLUDE "parm.tbl" INCLUDE "parmsoil" INCLUDE "mpp.h" P A R A M E T E R & (LP1=LM+1,JAM=6+2*(JM-10)) INCLUDE "PVRBLS.comm" INCLUDE "CTLBLK.comm" INCLUDE "PHYS.comm" INCLUDE "SOIL.comm" INCLUDE "MASKS.comm" DIMENSION HGT(IM,JM),SMORG(IM,JM) INTEGER IYR LOGICAL*1 BIT(IM,JM) INTEGER JPDS(25), JGDS(22), KGDS(22), KPDS(25) DATA LOROG/14/ IF (MYPE.EQ.0) THEN WRITE(*,*) " ************************************** " WRITE(*,*) " READ NEW SNOW/SI SICE SST ALBEDO GFRAC " WRITE(*,*) " READ NEW SNOW/SI SICE SST ALBEDO GFRAC " WRITE(*,*) " ************************************** " WRITE(0,*) " ************************************** " WRITE(0,*) " READ NEW SNOW/SI SICE SST ALBEDO GFRAC " WRITE(0,*) " READ NEW SNOW/SI SICE SST ALBEDO GFRAC " WRITE(0,*) " ************************************** " END IF C C C REWIND LOROG READ(LOROG)HGT,SMORG C C OPEN AF SNOW FILE C IF(MYPE.EQ.0) THEN CALL BAOPENR(42,'fort.42',IRET) IF (IRET.NE.0) THEN WRITE(0,*)'BAOPENR CAN NOT OPEN UNIT 42 IRET=',IRET CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF WRITE(0,*) 'BAOPENR ON UNIT42', ' IRET=', IRET C C READ AF SNOW C JPDS=-1 IF(IDAT(3).GE.2000) THEN IYR=2000-IDAT(3) ELSE IYR=IDAT(3)-1900 ENDIF JPDS(8)=IYR JPDS(9)=IDAT(1) JPDS(10)=IDAT(2) CALL GETGB(42,0,IM*JM,0,JPDS,JGDS,KF,K,KPDS,KGDS,BIT,TEMP1,IRET) WRITE(0,10) IRET,KF,KPDS(5), & (KPDS(21)*100+KPDS(8))/100-1, MOD(KPDS(8),100),KPDS(9), & KPDS(10) 10 FORMAT('IRET=',I3,' KF=', I6,' FLD=', I3, & 2X,'AF SNOW',1X, 4I2.2) IF (IRET.NE.0) THEN WRITE(0,*)"JPDS(8),JPDS(9),JPDS(10)",JPDS(8),JPDS(9),JPDS(10) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF ENDIF C C DISTRIBUTE AFSI TO ALL THE NODES C CALL DSTRB(TEMP1,AFSI,1,1,1) C C NOW CHECK THE AFSI AGAINST THE EDAS SNOW IN THE SI ARRAY. IF THE C 1/2*AFSI <= EDAS SNOW <= 2*AFSI, SET SIINC TO 0 AND LEAVE EDAS SNOW AS IS. C IF EDAS SNOW <= 1/2*AFSI, SET EDAS SNOW TO 1/2*AFSI AND SAVE THE INCREMENT. C IF EDAS SNOW >= 2*AFSI, SET EDAS SNOW TO 2*AFSI AND SAVE THE INCREMENT. C DO J=JDIM1,JDIM2 DO I=IDIM1,IDIM2 C C FIXME what for undefined values !!!!!!!!!!!!!!!!!! C IF (AFSI(I,J).LT.900.0) THEN IF (AFSI(I,J).EQ.0.0) THEN SI(I,J)=0.0 SNO(I,J)=0.0 ELSE IF (SI(I,J).EQ.0.0) THEN SI(I,J)=0.5*AFSI(I,J) SNO(I,J)=0.1*SI(I,J) ELSE IF (SI(I,J).GE.0.5*AFSI(I,J) .AND. & SI(I,J).LE.2.0*AFSI(I,J)) THEN SIINC=0.0 ELSE SIP=SI(I,J) SDENSP=SNO(I,J)/SI(I,J) IF (SI(I,J).LT.0.5*AFSI(I,J) ) THEN SIINC=SI(I,J)-0.5*AFSI(I,J) SI(I,J)=0.5*AFSI(I,J) ELSE IF (SI(I,J).GT.2.0*AFSI(I,J)) THEN SIINC=SI(I,J)-2.0*AFSI(I,J) SI(I,J)=2.0*AFSI(I,J) END IF SIRATIO=SI(I,J)/SIP IF (SIRATIO.LT.1.0) THEN SDENSN=(1.0-SIRATIO)*0.1 + SIRATIO*SDENSP ELSE IF (SIRATIO.GE.1.0 .AND. SIRATIO.LT.2.0) THEN SDENSN=SDENSP+(SIRATIO-1.0)/(2.0-1.0)*(0.1-SDENSP) ELSE SDENSN=0.1 END IF SNO(I,J)=SDENSN*SI(I,J) END IF END IF END IF IF (SNO(I,J).NE.0.0 .AND. SI(I,J).EQ.0.0) then WRITE(*,*) " I,J, SNO(I,J), SI(I,J)", & I,J, SNO(I,J), SI(I,J) WRITE(0,*) " I,J, SNO(I,J), SI(I,J)", & I,J, SNO(I,J), SI(I,J) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF END IF ENDDO ENDDO C C NOW READ IN THE SEA-ICE. C IF(MYPE.EQ.0) THEN CALL BAOPENR(43,'fort.43',IRET) IF (IRET.NE.0) THEN WRITE(0,*)'BAOPENR CAN NOT OPEN UNIT 43 IRET=',IRET CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF WRITE(0,*) 'BAOPENR ON UNIT 43', ' IRET=', IRET C JPDS=-1 IF(IDAT(3).GE.2000) THEN IYR=2000-IDAT(3) ELSE IYR=IDAT(3)-1900 ENDIF JPDS(8)=IYR JPDS(9)=IDAT(1) JPDS(10)=IDAT(2) CALL GETGB(43,0,IM*JM,0,JPDS,JGDS,KF,K,KPDS,KGDS,BIT,TEMP1,IRET) WRITE(0,11) IRET,KF,KPDS(5), & (KPDS(21)*100+KPDS(8))/100-1, MOD(KPDS(8),100),KPDS(9), & KPDS(10) 11 FORMAT('IRET=',I3,' KF=', I6,' FLD=', I3, & 2X,'SEA ICE',1X, 4i2.2) IF (IRET.NE.0) THEN WRITE(0,*)"JPDS(8),JPDS(9),JPDS(10)",JPDS(8),JPDS(9),JPDS(10) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF ENDIF C C DISTRIBUTE SEA ICE TO ALL THE NODES C CALL DSTRB(TEMP1,SICE,1,1,1) C C NOW READ IN THE SST. C IF(MYPE.EQ.0) THEN CALL BAOPENR(44,'fort.44',IRET) IF (IRET.NE.0) THEN WRITE(0,*)'BAOPENR CAN NOT OPEN UNIT 44 IRET=',IRET CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF WRITE(0,*) 'BAOPENR ON UNIT 44', ' IRET=', IRET C JPDS=-1 JPDS(8)=IYR JPDS(9)=IDAT(1) JPDS(10)=IDAT(2) CALL GETGB(44,0,IM*JM,0,JPDS,JGDS,KF,K,KPDS,KGDS,BIT,TEMP1,IRET) WRITE(0,12) IRET,KF,KPDS(5), & (KPDS(21)*100+KPDS(8))/100-1, MOD(KPDS(8),100),KPDS(9), & KPDS(10) 12 FORMAT('IRET=',I3,' KF=', I6,' FLD=', I3, & 2X,'SST',1X, 4i2.2) IF (IRET.NE.0) THEN WRITE(0,*)"JPDS(8),JPDS(9),JPDS(10)",JPDS(8),JPDS(9),JPDS(10) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF ENDIF C C DISTRIBUTE SST TO ALL THE NODES C CALL DSTRB(TEMP1,SST,1,1,1) C C NOW READ IN THE BASELINE ALBEDO. C IF(MYPE.EQ.0) THEN CALL BAOPENR(45,'fort.45',IRET) IF (IRET.NE.0) THEN WRITE(0,*)'BAOPENR CAN NOT OPEN UNIT 45 IRET=',IRET CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF WRITE(0,*) 'BAOPENR ON UNIT 45', ' IRET=', IRET C JPDS=-1 C JPDS(8)=IYR JPDS(9)=IDAT(1) JPDS(10)=IDAT(2) IF (JPDS(9).EQ.2.AND.JPDS(10).EQ.29) JPDS(10)=28 ! dusan (2003/05/06) CALL GETGB(45,0,IM*JM,0,JPDS,JGDS,KF,K,KPDS,KGDS,BIT,TEMP1,IRET) WRITE(0,13) IRET,KF,KPDS(5), & (KPDS(21)*100+KPDS(8))/100-1, MOD(KPDS(8),100),KPDS(9), & KPDS(10) 13 FORMAT('IRET=',I3,' KF=', I6,' FLD=', I3, & 2X,'ALBEDO',1X, 4I2.2) IF (IRET.NE.0) THEN WRITE(0,*)"JPDS(8),JPDS(9),JPDS(10)",JPDS(8),JPDS(9),JPDS(10) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF ENDIF C C DISTRIBUTE ALBASE TO ALL THE NODES C CALL DSTRB(TEMP1,ALBASE,1,1,1) C C FINALLY READ IN THE GREENNESS FRACTION. C IF(MYPE.EQ.0) THEN CALL BAOPENR(46,'fort.46',IRET) IF (IRET.NE.0) THEN WRITE(0,*)'BAOPENR CAN NOT OPEN UNIT 46 IRET=',IRET CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF WRITE(0,*) 'BAOPENR ON UNIT 46', ' IRET=', IRET C JPDS=-1 C JPDS(8)=IYR JPDS(9)=IDAT(1) JPDS(10)=IDAT(2) IF (JPDS(9).EQ.2.AND.JPDS(10).EQ.29) JPDS(10)=28 ! dusan (2003/05/06) CALL GETGB(46,0,IM*JM,0,JPDS,JGDS,KF,K,KPDS,KGDS,BIT,TEMP1,IRET) WRITE(0,14) IRET,KF,KPDS(5), & (KPDS(21)*100+KPDS(8))/100-1, MOD(KPDS(8),100),KPDS(9), & KPDS(10) 14 FORMAT('IRET=',I3,' KF=', I6,' FLD=', I3, & 2X,'GREENNESS FRACTION',1X, 4I2.2) IF (IRET.NE.0) THEN WRITE(0,*)"JPDS(8),JPDS(9),JPDS(10)",JPDS(8),JPDS(9),JPDS(10) CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF ENDIF C C DISTRIBUTE VEGFRC TO ALL THE NODES C CALL DSTRB(TEMP1,VEGFRC,1,1,1) C CCC CCC CCC DO J=JDIM1,JDIM2 DO I=IDIM1,IDIM2 IF (SMORG(I,J).LT.0.5.AND.SICE(I,J).LT.0.5) THEN C LANDMASS SM(I,J)=0.0 SICE(I,J)=0.0 ELSE IF ((SMORG(I,J).LT.0.5.AND.SICE(I,J).GT.0.5) THEN C SEA-ICE SM(I,J)=0.0 SICE(I,J)=1.0 ALBEDO(I,J)=0.60 ELSE IF ((SMORG(I,J).GT.0.5.AND.SICE(I,J).LT.0.5) THEN C OPEN SEA SM(I,J)=1.0 SICE(I,J)=0.0 ALBEDO(I,J)=0.06 ELSE WRITE(*,*)'READGRDETA: SHOULD NOT BE HERE' WRITE(0,*)'READGRDETA: SHOULD NOT BE HERE' CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) STOP END IF END DO END DO C RETURN END