SUBROUTINE inicma(kastp,kexch,kstep) IMPLICIT none c INTEGER kastp, kexch, kstep c INTEGER ime PARAMETER (ime = 1) c C**** C ***************** C * OASIS ROUTINE * C * ------------- * C ***************** C C**** *INICMA* - Initialize coupled mode communication for atmosphere C C Purpose: C ------- C Exchange process identifiers and timestep information C between AGCM, OGCM and COUPLER. C C Input: C ----- C KASTP : total number of timesteps in atmospheric model C KEXCH : frequency of exchange (in time steps) C KSTEP : timestep value (in seconds) C C Method: C ------ C Use named pipes(FIFO) to exchange process identifiers C between the programs C C Externals: C --------- C GETPID, MKNOD C C Reference: C --------- C See Epicoa 0803 (1992) C C Author: C ------- C Laurent Terray 92-09-01 C C ----------------------------------------------------------- C INTEGER imess(4) INTEGER getpid, mknod ! system functions CHARACTER*80 clcmd CHARACTER*8 pipnom, fldnom INTEGER ierror C #include "dimensions.h" #include "dimphy.h" #include "oasis.h" #include "clim.h" c INTEGER iparal(3) INTEGER istep, ifcpl, idt, info, imxtag c INTEGER mode, iret, isize C INTEGER nuout PARAMETER (nuout = 6) C ----------------------------------------------------------- C C* 1. Initializations C --------------- C WRITE(nuout,*) ' ' WRITE(nuout,*) ' ' WRITE(nuout,*) ' ROUTINE INICMA' WRITE(nuout,*) ' **************' WRITE(nuout,*) ' ' WRITE(nuout,*) ' ' c IF (cchain.EQ."PIPE") THEN c WRITE(nuout,*) " " WRITE(nuout,*) "Making pipes for fields to receive from CPL" WRITE(nuout,*) " " c c zxli(le17fev97): je ne comprends pas pourquoi il faut c avoir 2 noms pour un seul pipe c pipnom = "SISUTESU" fldnom = "Sisutesu" #ifdef CRAY clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "SIALBEDO" fldnom = "Sialbedo" #ifdef CRAY clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "SIICECOV" fldnom = "Siicecov" #ifdef CRAY clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "SIICEALB" fldnom = "Siicealb" #ifdef CRAY clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c WRITE(nuout,*) " " WRITE(nuout,*) "Making pipes for fields to send to CPL" WRITE(nuout,*) " " c pipnom = "CONSFTOT" fldnom = "Consftot" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COSSTSST" fldnom = "Cosstsst" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "CODFLXDT" fldnom = "Codflxdt" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COSHFTOT" fldnom = "Coshftot" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COALBSUR" fldnom = "Coalbsur" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COTOSPSU" fldnom = "Cotospsu" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COTOLPSU" fldnom = "Cotolpsu" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COTFSHSU" fldnom = "Cotfshsu" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "CORUNCOA" fldnom = "Coruncoa" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "CORIVFLU" fldnom = "Corivflu" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COZOTAUX" fldnom = "Cozotaux" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COMETAUY" fldnom = "Cometauy" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COZOTAU2" fldnom = "Cozotau2" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c pipnom = "COMETAU2" fldnom = "Cometau2" #ifdef CRAY clcmd = "assign -s u -a "//pipnom//" f:"//fldnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) WRITE(nuout,'(a80)') clcmd #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) WRITE(nuout,'(a80)') clcmd #endif c WRITE(nuout,*) " " WRITE(nuout,*) "All pipes have been made" WRITE(nuout,*) " " CALL flush(nuout) c WRITE(nuout,*) " " WRITE(nuout,*) "Communication test between ATM and CPL" WRITE(nuout,*) " " c WRITE (pipnom,'(a6,i2.2)') "Preadm", ime #ifdef CRAY clcmd = "assign -s u f:"//pipnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) #endif WRITE(nuout,'(a80)') clcmd imess(1) = kastp imess(2) = kexch imess(3) = kstep imess(4) = getpid() #ifdef CRAY WRITE (pipnom) imess ! send message to pipe #else iret=0 isize=4 CALL pipwrite(pipnom, imess, isize, iret) #endif WRITE(nuout,*) "Msg sent to pipe "//pipnom CALL flush(nuout) c WRITE (pipnom,'(a6,i2.2)') "Pwritm", ime #ifdef CRAY clcmd = "assign -s unblocked f:"//pipnom CALL assign(clcmd, ierror) ierror = mknod (pipnom, 4480, 0) #else clcmd = "CALL makepipe("//pipnom//",...,...)" mode = o'010600' iret = 0 CALL makepipe(pipnom, mode, iret) #endif WRITE(nuout,'(a80)') clcmd c WRITE(nuout,*) "Waiting for the pipe "//pipnom CALL flush(nuout) #ifdef CRAY READ (pipnom) imess ! read message from pipe #else isize=1 iret =0 CALL pipread(pipnom,imess,isize,iret) #endif c WRITE(nuout,*) " " WRITE(nuout,*) "Communication test between ATM and CPL is OK" WRITE(nuout,*) " total simulation time in oasis = ", imess(1) WRITE(nuout,*) " total number of iterations is = ", imess(2) WRITE(nuout,*) " value of oasis timestep is = ", imess(3) WRITE(nuout,*) " process id for oasis is = ", imess(4) WRITE(nuout,*) " " CALL flush(nuout) c ELSE ! cchain.EQ."CLIM" c CALL CLIM_Init ( 'CLI', 'lmd.xx', 3, 7, * kastp, kexch, kstep, * 5, 1200, 300, info ) IF (info.EQ.CLIM_Ok) THEN WRITE(nuout,*) "inicma: CLIM_Init OK" ELSE WRITE(nuout,*) "inicma: CLIM_Init erreur:", info CALL ABORT("STOP in inicma") ENDIF c iparal ( CLIM_Strategy ) = CLIM_Serial iparal ( CLIM_Length ) = iim*(jjm+1) iparal ( CLIM_Offset ) = 0 c CALL CLIM_Define ('SISUTESU', CLIM_In , CLIM_Double, iparal, info) CALL CLIM_Define ('SIALBEDO', CLIM_In , CLIM_Double, iparal, info) CALL CLIM_Define ('SIICECOV', CLIM_In , CLIM_Double, iparal, info) CALL CLIM_Define ('SIICEALB', CLIM_In , CLIM_Double, iparal, info) c CALL CLIM_Define ('CONSFTOT', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COSSTSST', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('CODFLXDT', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COSHFTOT', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COALBSUR', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COTOSPSU', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COTOLPSU', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COTFSHSU', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('CORUNCOA', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('CORIVFLU', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COZOTAUX', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COMETAUY', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COZOTAU2', CLIM_Out , CLIM_Double, iparal,info) CALL CLIM_Define ('COMETAU2', CLIM_Out , CLIM_Double, iparal,info) WRITE(nuout,*) 'inicma : CLIM_Define ok ' c CALL CLIM_Start ( imxtag, info ) IF (info.NE.CLIM_Ok) THEN WRITE (nuout,*) "inicma: CLIM_Start pb. ", info CALL ABORT("STOP in inicma") ELSE WRITE (nuout,*) "inicma: CLIM_Start OK" ENDIF c CALL CLIM_Stepi ("oasis", istep, ifcpl, idt, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "inicma: CLIM_Stepi pb. ", info CALL ABORT("STOP in inicma") ELSE WRITE (nuout,*) "inicma: CLIM_Stepi OK" WRITE (nuout,*) " number of tstep in oasis ", istep WRITE (nuout,*) " exchange frequency in oasis ", ifcpl WRITE (nuout,*) " length of tstep in oasis ", idt ENDIF c ENDIF c RETURN END SUBROUTINE fromcpl(jour, imjm, sst, sic, alb_sst, alb_sic) IMPLICIT none c c Laurent Z.X Li (Feb. 10, 1997): It reads the SST and Sea-Ice c provided by the coupler. Of course, it waits until it receives c the signal from the corresponding pipes in the case of utilizing c the pipe technique. c INTEGER imjm, jour REAL sst(imjm) ! sea surface temperature REAL alb_sst(imjm) ! open sea albedo REAL sic(imjm) ! sea ice cover REAL alb_sic(imjm) ! sea ice albedo c INTEGER nuout ! listing output unit PARAMETER (nuout=6) c INTEGER nuread, ios, iflag, icpliter CHARACTER*8 pipnom ! name for the pipe CHARACTER*8 fldnom ! name for the field CHARACTER*8 filnom ! name for the data file c #include "oasis.h" #include "clim.h" INTEGER info, jktm1 INTEGER iret, isize c WRITE (nuout,*) " " WRITE (nuout,*) "Fromcpl: Read fields from CPL" WRITE (nuout,*) " " CALL flush (nuout) c IF (cchain.EQ."PIPE") THEN c c sea-surface-temperature: c pipnom = "Sisutesu" fldnom = "SISUTESU" filnom = "atmsst" WRITE (nuout,*) "Waiting for the pipe "//pipnom CALL flush (nuout) #ifdef CRAY READ (pipnom) icpliter #else iret = 0 isize = 1 CALL pipread(pipnom, icpliter, isize, iret) #endif WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom CALL flush (nuout) nuread = 99 OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(nuout,*) "Error while connecting "//filnom, nuread CALL flush (nuout) CALL ABORT("STOP in Fromcpl") ENDIF REWIND (UNIT = nuread) WRITE(nuout,*) "Reading "//fldnom//" from "//filnom CALL flush (nuout) CALL locread(fldnom, sst, imjm, nuread, iflag) IF (iflag .NE. 0) THEN WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom WRITE(nuout,*) "jour, iflag = ", jour, iflag CALL flush (nuout) CALL ABORT('STOP in Fromcpl') ENDIF CLOSE(nuread) WRITE(nuout,*) "Succesful for reading "//fldnom CALL flush (nuout) c c open sea albedo: c pipnom = "Sialbedo" fldnom = "SIALBEDO" filnom = "atmice" WRITE (nuout,*) "Waiting for the pipe "//pipnom CALL flush (nuout) #ifdef CRAY READ (pipnom) icpliter #else iret = 0 isize = 1 CALL pipread(pipnom, icpliter, isize, iret) #endif WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom CALL flush (nuout) nuread = 99 OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(nuout,*) "Error while connecting "//filnom, nuread CALL flush (nuout) CALL ABORT("STOP in Fromcpl") ENDIF REWIND (UNIT = nuread) WRITE(nuout,*) "Reading "//fldnom//" from "//filnom CALL flush (nuout) CALL locread(fldnom, alb_sst, imjm, nuread, iflag) IF (iflag .NE. 0) THEN WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom WRITE(nuout,*) "jour, iflag = ", jour, iflag CALL flush (nuout) CALL ABORT('STOP in Fromcpl') ENDIF CLOSE(nuread) WRITE(nuout,*) "Succesful for reading "//fldnom CALL flush (nuout) c c sea-ice cover: c pipnom = "Siicecov" fldnom = "SIICECOV" filnom = "atmice" WRITE (nuout,*) "Waiting for the pipe "//pipnom CALL flush (nuout) #ifdef CRAY READ (pipnom) icpliter #else iret = 0 isize = 1 CALL pipread(pipnom, icpliter, isize, iret) #endif WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom CALL flush (nuout) nuread = 99 OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(nuout,*) "Error while connecting "//filnom, nuread CALL flush (nuout) CALL ABORT("STOP in Fromcpl") ENDIF REWIND (UNIT = nuread) WRITE(nuout,*) "Reading "//fldnom//" from "//filnom CALL flush (nuout) CALL locread(fldnom, sic, imjm, nuread, iflag) IF (iflag .NE. 0) THEN WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom WRITE(nuout,*) "jour, iflag = ", jour, iflag CALL flush (nuout) CALL ABORT('STOP in Fromcpl') ENDIF CLOSE(nuread) WRITE(nuout,*) "Succesful for reading "//fldnom CALL flush (nuout) c c sea-ice albedo: c pipnom = "Siicealb" fldnom = "SIICEALB" filnom = "atmice" WRITE (nuout,*) "Waiting for the pipe "//pipnom CALL flush (nuout) #ifdef CRAY READ (pipnom) icpliter #else iret = 0 isize = 1 CALL pipread(pipnom, icpliter, isize, iret) #endif WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom CALL flush (nuout) nuread = 99 OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(nuout,*) "Error while connecting "//filnom, nuread CALL flush (nuout) CALL ABORT("STOP in Fromcpl") ENDIF REWIND (UNIT = nuread) WRITE(nuout,*) "Reading "//fldnom//" from "//filnom CALL flush (nuout) CALL locread(fldnom, alb_sic, imjm, nuread, iflag) IF (iflag .NE. 0) THEN WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom WRITE(nuout,*) "jour, iflag = ", jour, iflag CALL flush (nuout) CALL ABORT('STOP in Fromcpl') ENDIF CLOSE(nuread) WRITE(nuout,*) "Succesful for reading "//fldnom CALL flush (nuout) c ELSE ! cchain.EQ."CLIM" c jktm1=jour-1 c CALL CLIM_Import ('SISUTESU', jktm1, sst, info) IF (info .NE. CLIM_Ok) THEN WRITE(nuout,*)'Pb in reading ', 'SISUTESU' WRITE(nuout,*)'Atmosphere jour is = ',jour WRITE(nuout,*)'Couplage kt is = ',jktm1 WRITE(nuout,*)'CLIM error code is = ', info WRITE(nuout,*)'STOP in Fromcpl' CALL abort ENDIF c CALL CLIM_Import ('SIALBEDO', jktm1, alb_sst, info) IF (info .NE. CLIM_Ok) THEN WRITE(nuout,*)'Pb in reading ', 'SIALBEDO' WRITE(nuout,*)'Atmosphere jour is = ',jour WRITE(nuout,*)'Couplage kt is = ',jktm1 WRITE(nuout,*)'CLIM error code is = ', info WRITE(nuout,*)'STOP in Fromcpl' CALL abort ENDIF c CALL CLIM_Import ('SIICECOV', jktm1, sic, info) IF (info .NE. CLIM_Ok) THEN WRITE(nuout,*)'Pb in reading ', 'SIICECOV' WRITE(nuout,*)'Atmosphere jour is = ',jour WRITE(nuout,*)'Couplage kt is = ',jktm1 WRITE(nuout,*)'CLIM error code is = ', info WRITE(nuout,*)'STOP in Fromcpl' CALL abort ENDIF c CALL CLIM_Import ('SIICEALB', jktm1, alb_sic, info) IF (info .NE. CLIM_Ok) THEN WRITE(nuout,*)'Pb in reading ', 'SIICEALB' WRITE(nuout,*)'Atmosphere jour is = ',jour WRITE(nuout,*)'Couplage kt is = ',jktm1 WRITE(nuout,*)'CLIM error code is = ', info WRITE(nuout,*)'STOP in Fromcpl' CALL abort ENDIF c ENDIF ! fin de test sur cchain c RETURN END SUBROUTINE locread (cdfldn, pfield, kdimax, knulre, kflgre) IMPLICIT none INTEGER kdimax, knulre, kflgre C**** C ***************************** C * OASIS ROUTINE - LEVEL 0 * C * ------------- ------- * C ***************************** C C**** *locread* - Read binary field on unit knulre C C Purpose: C ------- C Find string cdfldn on unit knulre and read array pfield C C** Interface: C --------- C *CALL* *locread (cdfldn, pfield, kdimax, knulre, kflgre)* C C Input: C ----- C cdfldn : character string locator C kdimax : dimension of field to be read C knulre : logical unit to be read C C Output: C ------ C pfield : field array (real 1D) C kflgre : error status flag C C Workspace: C --------- C None C C Externals: C --------- C None C C Reference: C --------- C See OASIS manual (1995) C C History: C ------- C Version Programmer Date Description C ------- ---------- ---- ----------- C 2.0 L. Terray 95/09/01 created C C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% C C* ---------------------------- Include files --------------------------- C C C* ---------------------------- Argument declarations ------------------- C REAL pfield(kdimax) CHARACTER*8 cdfldn C C* ---------------------------- Local declarations ---------------------- C CHARACTER*8 clecfl INTEGER nulou c nulou = 6 C C* ---------------------------- Poema verses ---------------------------- C C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% C C* 1. Initialization C -------------- C c WRITE (UNIT = nulou,FMT = *) ' ' c WRITE (UNIT = nulou,FMT = *) ' ' c WRITE (UNIT = nulou,FMT = *) c $ ' ROUTINE locread - Level 0' c WRITE (UNIT = nulou,FMT = *) c $ ' *************** *******' c WRITE (UNIT = nulou,FMT = *) ' ' c WRITE (UNIT = nulou,FMT = 1001) knulre c WRITE (UNIT = nulou,FMT = *) ' ' C C* Formats C 1001 FORMAT(5X,' Read binary file connected to unit = ',I3) C C 2. Find field in file C ------------------ C REWIND knulre 200 CONTINUE C* Find string READ (UNIT = knulre, ERR = 210, END = 210) clecfl IF (clecfl .NE. cdfldn) GO TO 200 C* Read associated field READ (UNIT = knulre, ERR = 210, END = 210) pfield C* Reading done and ok kflgre = 0 GO TO 220 C* Problem in reading 210 kflgre = 1 220 CONTINUE C C C* 3. End of routine C -------------- C c WRITE (UNIT = nulou,FMT = *) c $ ' --------- End of routine locread ---------' c WRITE (UNIT = nulou,FMT = *) ' ' c CALL FLUSH (nulou) RETURN END SUBROUTINE intocpl(itau,imjm, . fsol, fnsol, . rain, snow, evap, ruisoce, ruisriv, . tsol, fder, albe, . taux, tauy) IMPLICIT NONE c c Laurent Z.X Li (Feb. 10, 1997): It provides several fields to the c coupler. Of course, it sends a message to the corresponding pipes c after the writting. c INTEGER itau, imjm c REAL fsol(imjm) REAL fnsol(imjm) REAL rain(imjm) REAL snow(imjm) REAL evap(imjm) REAL ruisoce(imjm) REAL ruisriv(imjm) REAL tsol(imjm) REAL fder(imjm) REAL albe(imjm) REAL taux(imjm) REAL tauy(imjm) c INTEGER nuout PARAMETER (nuout = 6) C INTEGER nuwrit, ios CHARACTER*8 pipnom CHARACTER*8 fldnom CHARACTER*8 filnom c c #include "oasis.h" #include "clim.h" INTEGER info INTEGER isize, iret c WRITE(nuout,*) " " WRITE(nuout,*) "Intocpl: send fields to CPL, itau= ", itau WRITE(nuout,*) " " c IF (cchain.EQ."PIPE") THEN c nuwrit = 99 filnom = "atmflx" OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(6,*) "Error while connecting "//filnom CALL ABORT('STOP in intocpl') ENDIF REWIND ( UNIT = nuwrit) c WRITE(nuout,*) " " WRITE(nuout,*) "Writting fields to "//filnom, nuwrit WRITE(nuout,*) " " CALL flush(nuout) C C ecriture CONSFTOT (flux non solaire) C fldnom = "CONSFTOT" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) fnsol WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COSHFTOT (solaire) C fldnom = "COSHFTOT" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) fsol WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COTOLPSU (precipitation liquide) C fldnom = "COTOLPSU" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) rain WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COTOSPSU (precipitation solide) C fldnom = "COTOSPSU" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) snow WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COTFSHSU (evaporation) C fldnom = "COTFSHSU" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) evap WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COSSTSST (temperature du sol) C fldnom = "COSSTSST" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) tsol WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture CODFLXDT (derivee du flux non-solaire) C fldnom = "CODFLXDT" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) fder WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COALBSUR (albedo moyen) C fldnom = "COALBSUR" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) albe WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture CORUNCOA (runoff DIRECT) C fldnom = "CORUNCOA" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) ruisoce WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture river runoff 'CORIVFLU' C fldnom = "CORIVFLU" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) ruisriv WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit c CLOSE(UNIT = nuwrit) C C simulate a FLUSH C OPEN(nuwrit, FILE=filnom, FORM='unformatted') CLOSE(UNIT = nuwrit) C C Send message to pipes: c pipnom = 'Consftot' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Coshftot' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cotolpsu' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cotospsu' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cotfshsu' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cosstsst' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Codflxdt' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Coalbsur' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Coruncoa' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Corivflu' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom C C Send wind stresses to coupler c nuwrit = 99 filnom = "atmtau" OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios) IF (ios .NE. 0) THEN WRITE(6,*) "Error while connecting "//filnom CALL ABORT('STOP in intocpl') ENDIF REWIND ( UNIT = nuwrit) c WRITE(nuout,*) " " WRITE(nuout,*) "Writting fields to "//filnom, nuwrit WRITE(nuout,*) " " C C ecriture COZOTAUX c fldnom = "COZOTAUX" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) taux WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit c fldnom = "COZOTAU2" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) taux WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit C C ecriture COMETAUY C fldnom = "COMETAUY" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) tauy WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit c fldnom = "COMETAU2" WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA ' WRITE(UNIT = nuwrit) tauy WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit c CLOSE(UNIT = nuwrit) C C simulate a FLUSH C OPEN(nuwrit, FILE=filnom, FORM='unformatted') CLOSE(UNIT = nuwrit) c c Send message to pipes: c pipnom = 'Cozotaux' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cozotau2' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cometauy' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c pipnom = 'Cometau2' #ifdef CRAY WRITE(pipnom) itau #else isize=1 iret=0 CALL pipwrite(pipnom,itau,isize,iret) #endif WRITE(nuout,*) "Message sent to pipe "//pipnom c ELSE ! cchain.EQ."CLIM" c CALL CLIM_Export("CONSFTOT", itau, fnsol, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export fnsol pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COSHFTOT", itau, fsol, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export fsol pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COTOLPSU", itau, rain, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export rain pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COTOSPSU", itau, snow, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export snow pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COTFSHSU", itau, evap, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export evap pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COSSTSST", itau, tsol, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export tsol pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("CODFLXDT", itau, fder, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COALBSUR", itau, albe, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("CORUNCOA", itau, ruisoce, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export ruisoce pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("CORIVFLU", itau, ruisriv, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export ruisriv pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COZOTAUX", itau, taux, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COZOTAU2", itau, taux, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COMETAUY", itau, tauy, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info CALL ABORT("STOP in intocpl") ENDIF c CALL CLIM_Export("COMETAU2", itau, tauy, info) IF (info .NE. CLIM_Ok) THEN WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info CALL ABORT("STOP in intocpl") ENDIF c ENDIF c RETURN END SUBROUTINE quitcpl IMPLICIT none c c Sortir du coupleur c INTEGER nuout ! listing output unit PARAMETER (nuout=6) c #include "oasis.h" #include "clim.h" INTEGER info c IF (cchain.EQ."PIPE") THEN c WRITE(nuout,*)"On sort du coupleur sans rien faire" c ELSE ! cchain.EQ."CLIM" c CALL CLIM_Quit(CLIM_StopPvm,info) IF (info.NE.CLIM_Ok) THEN WRITE(nuout,*)"Erreur pour quiter coupleur:",info ENDIF c ENDIF c RETURN END SUBROUTINE makepipe PRINT*, "rien" END SUBROUTINE pipwrite PRINT*, "rien" END SUBROUTINE pipread PRINT*, "rien" END SUBROUTINE CLIM_Init PRINT*, "rien" END SUBROUTINE CLIM_Define PRINT*, "rien" END SUBROUTINE CLIM_Start PRINT*, "rien" END SUBROUTINE CLIM_Stepi PRINT*, "rien" END SUBROUTINE CLIM_Import PRINT*, "rien" END SUBROUTINE CLIM_Export PRINT*, "rien" END SUBROUTINE CLIM_quit PRINT*, "rien" END