!-------------------------------------- LICENCE BEGIN ------------------------------------ !Environment Canada - Atmospheric Science and Technology License/Disclaimer, ! version 3; Last Modified: May 7, 2008. !This is free but copyrighted software; you can use/redistribute/modify it under the terms !of the Environment Canada - Atmospheric Science and Technology License/Disclaimer !version 3 or (at your option) any later version that should be found at: !http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html ! !This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; !without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !See the above mentioned License/Disclaimer for more details. !You should have received a copy of the License/Disclaimer along with this software; !if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec), !CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca !-------------------------------------- LICENCE END --------------------------------------subroutine itf_cpl_namcpl (F_ocename_S,F_filename,F_write_S, $ F_read_S,F_nw,F_nr,n,errc) implicit none * integer F_nw,F_nr,n,errc character*(*) F_ocename_S,F_filename,F_write_S(n),F_read_S(n) * *authors Michel Desgagne - Spring 2008 * *revision * v3_31 - Desgagne M. - initial MPI version ** character*512 string,rs,s1(2) logical found_my_name integer i,cnt_w,cnt_r,indx,lst,longueur external longueur * * --------------------------------------------------------------- * F_nw = 0 F_nr = 0 errc = -1 found_my_name=.false. * lst = len(rs) open(47,file=F_filename,form='formatted',status='old',err=71) * cnt_w=0 cnt_r=0 1 read(47,'(a72)',end=71) string rs = string if ((longueur(rs)>0).and.(rs(1:1).ne."#")) then * do i=1,2 2 indx = index (rs,' ') if (indx.eq.lst) stop if (indx.eq.1) then rs = rs(indx+1:lst) goto 2 endif s1(i) = rs(1:indx-1) rs = rs(indx+1:lst) end do if (s1(1)(1:7).eq."MODELS:") then do i=1,2 3 indx = index (rs,' ') if (indx.eq.lst) stop if (indx.eq.1) then rs = rs(indx+1:lst) goto 3 endif s1(i) = rs(1:indx-1) rs = rs(indx+1:lst) end do if ((s1(1)(1:6).eq.F_ocename_S(1:6)).or. $ (s1(2)(1:6).eq.F_ocename_S(1:6))) found_my_name=.true. else if (s1(1)(1:4).eq.F_ocename_S(1:4)) then cnt_w=cnt_w+1 if (cnt_w.gt.n) then write (6,9001) return endif F_write_S(cnt_w) = s1(1) endif if (s1(2)(1:4).eq.F_ocename_S(1:4)) then cnt_r=cnt_r+1 if (cnt_r.gt.n) then write (6,9001) return endif F_read_S(cnt_r) = s1(2) endif endif endif goto 1 * 71 if (.not.found_my_name) then write (6,9002) errc = -1 return endif * F_nw = cnt_w F_nr = cnt_r errc = 0 * 9001 format (/' itf_cpl_namcpl: MORE COUPLING VARIABLES THAN ALLOWED in itf_oasis.cdk'/) 9002 format (/' itf_cpl_namcpl: NOT a member of the OASIS COUPLER'/) * * --------------------------------------------------------------- * return end