C Example code demonstrating Fortran MDSplus access to C International Profile Database. C NB Must be linked with libMdsLib.a C program IPDB_MDS implicit none include 'mdslib.inc' external descr integer status character cresult*25 C integer nptsx,nptsy,nptsz,ierror/0/,ittyrd/5/,ittywr/6/ integer lenstr parameter (lenstr=30) character*30 server/'tokamak-profiledb.ccfe.ac.uk'/ c character*30 server/'localhost'/ character*9 tree/'pr98_cmod'/ character*40 signal character*80 errmsg integer ishot/960116024/, irank integer ianswer, iretlen/0/, L,JSIG character*(lenstr) xlab, ylab, zlab integer MAXPTS, idate, iudate, ish parameter (MAXPTS=81920) real x(MAXPTS), y(MAXPTS), z(MAXPTS), pgasa,ip C Make connection if (server.ne.'localhost') then status = MdsConnect(server) if (status/2*2 .eq. status) then write(6,*) 'Mdsconnected to server ',server write(6,*) 'Mdsconnect returns status= ',status else write(6,*) 'Mds SUCCESSFULLY connected to server ',server endif endif C Open tree status = MdsOpen(tree, ishot) if (status/2*2 .eq. status) then write(6,*) 'MdsOpen FAILS for (tree, ishot) :',tree,ishot write(6,*) 'MdsOpen returns status= ',status else write (6,*) 'MdsOpen SUCCESS for (tree, ishot): ',tree,ishot endif C C Get integer, string, and real 0-D values ianswer = descr(IDTYPE_LONG,ish,0) status = MdsValue('.zerod:shot'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' SHOT: ',ish, status ianswer = descr(IDTYPE_LONG,idate,0) status = MdsValue('.zerod:date'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' DATE: ',idate, status ianswer = descr(IDTYPE_LONG,iudate,0) status = MdsValue('.zerod:update'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' UPDATE: ',iudate, status ianswer = descr(IDTYPE_FLOAT,pgasa,0) status = MdsValue('.zerod:pgasa'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' PGASA: ',pgasa, status C ianswer = descr(IDTYPE_CSTRING,cresult,0,LEN(cresult)) status = MdsValue('.zerod:phase'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' PHASE: ',cresult, status C ianswer = descr(IDTYPE_FLOAT,ip,0) status = MdsValue('.zerod:ip'//CHAR(0),ianswer, 0, iretlen) write (6,*) ' Plasma current: ',ip, status C C Loop over 1 and 2-D signals DO 500 JSIG=1,2 IF(JSIG.EQ.1) THEN SIGNAL='.oned:ip' ELSEIF(JSIG.EQ.2) THEN SIGNAL='.twod:ne' ENDIF C Get the rank of a signal: ianswer = descr(IDTYPE_LONG,irank,0) status = MdsValue('rank('//signal//')'//CHAR(0),ianswer, 0, 1 iretlen) write (6,*) write (6,*) ' Signal=',signal write (6,*) ' Rank of signal: ', irank C Get x units ianswer = descr(IDTYPE_CSTRING,xlab,0,LEN(xlab)) status = MdsValue('units_of(dim_of('//signal//',0))'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' X units: ',xlab C Get number of x points ianswer = descr(IDTYPE_LONG,nptsx,0) status = MdsValue('size(dim_of('//signal//',0))'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Number of X points: ', nptsx C Data access for X ianswer = descr(IDTYPE_FLOAT,X,MAXPTS,0) status = MdsValue('dim_of('//signal//',0)'//CHAR(0),ianswer, 1 0, iretlen) write (6,*) ' X array length: ',iretlen write (6,*) ' X array: ',(x(L),L=1,3) if(irank.eq.1) then C Get Y units (if a 1-D signal) ianswer = descr(IDTYPE_CSTRING,ylab,0,LEN(ylab)) status = MdsValue('units_of('//signal//')'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Y units: ',ylab C Get number of y points (if a 1-D signal) ianswer = descr(IDTYPE_LONG,nptsy,0) status = MdsValue('size('//signal//')'//CHAR(0),ianswer, 1 0, iretlen) write (6,*) ' Number of Y points: ', nptsy C Data access for Y (if a 1-D signal) ianswer = descr(IDTYPE_FLOAT,Y,MAXPTS,0) status = MdsValue(signal//CHAR(0),ianswer, 0, iretlen) write (6,*) ' Y array length: ',iretlen write (6,*) ' Y array: ',(y(L),L=1,3) elseif(irank.eq.2) then C Get Y units (if a 2-D signal) ianswer = descr(IDTYPE_CSTRING,ylab,0,LEN(zlab)) status = MdsValue('units_of(dim_of('//signal//',1))' 1 //CHAR(0),ianswer, 0, iretlen) write (6,*) ' Y units: ',ylab C Get number of Y points ianswer = descr(IDTYPE_LONG,nptsy,0) status = MdsValue('size(dim_of('//signal//',1))'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Number of Y points: ', nptsy C Data access for Y (if a 2-D signal) ianswer = descr(IDTYPE_FLOAT,Y,MAXPTS,0) status = MdsValue('dim_of('//signal//',1)'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Y array length: ',iretlen write (6,*) ' Y array: ',(y(L),L=1,3) C Get Z units (if a 2-D signal) ianswer = descr(IDTYPE_CSTRING,zlab,0,LEN(xlab)) status = MdsValue('units_of('//signal//')'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Z units: ',zlab C Get number of z points (if a 2-D signal) ianswer = descr(IDTYPE_LONG,nptsz,0) status = MdsValue('size('//signal//')'//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Number of Z points: ', nptsz C Data access for Z (if a 2-D signal) ianswer = descr(IDTYPE_FLOAT,Z,MAXPTS,0) status = MdsValue(signal//CHAR(0), 1 ianswer, 0, iretlen) write (6,*) ' Z array length: ',iretlen write (6,*) ' Z array: ',(z(L),L=1,3) else write(ittywr,'('' Not prepared for rank ='',I)') irank stop endif 500 CONTINUE 600 CONTINUE if (server.ne.'localhost') status = MdsDisconnect() end integer function mds_errstr(ierr, str) implicit none integer ierr character*(*) str integer dsc, size, status character*19 cmd integer mdsfdescr, mdsfvalue, mds__cstring write(cmd, '(''GETMSG('',I11,'')'')') ierr c dsc = mdsfdescr(mds__cstring(), str, 0, len(str)) c status = mdsfvalue(cmd //char(0), dsc, 0, size) c call mds_addblanks(str) mds_errstr = status return end